Quantcast
Channel: VBForums - CodeBank - Visual Basic 6 and earlier
Viewing all 1542 articles
Browse latest View live

VB - SnipSnap: Copy/Cut & Paste Image Areas

$
0
0
Earlier versions of this were called "MaskoMania" but a lot has been cleaned up and additional functionality added.

Basically it is a UserControl to be hosted within a container control with a bitmap image. The user can "lasso" a rectangle to be cut or copied, dragged then pasted.

Code:

'Mouse Actions:
'-------------
'
'When Enabled = True the mouse performs the following actions.  When Enabled = False
'the events pass through with no processing.
'
'On the container:
'
'  Left-click to clear the selection.
'
'  Left-drag then release to establish the selection and copy or cut from the
'  container's bitmap.  See the Cutting property.  A cut operation backfills with
'  the MaskColor.  A very small drag acts like a click.
'
'  Shift-left-click makes Masking = False.
'
'  Shift-right-click to choose the color under the mouse as MaskColor and make
'  Masking = True.
'
'On the control:
'
'  Left-drag to move the control.
'
'  Shift-left-click makes Masking = False.
'
'  Right-click pastes the contents of the control into the container bitmap.
'
'  Shift-right-click to choose the color under the mouse as MaskColor and make
'  Masking = True.

Masking is used to designate a transparent color. Minimalist demo:

Name:  sshot.png
Views: 18
Size:  9.3 KB

There is also another demo in the attachment. It covers a wider set of features available, like passing a snippet from one container to another or loading an external file as a snippet.
Attached Images
 
Attached Files

VB6 Color Picker usercontrol with Save Color Picks

$
0
0
Drop this usercontrol in app and start picking colors. It will save 8 sample colors for you.
Attached Files

Charts controls with GDI+

$
0
0
It is a suite of user controls, to create statistical graphs. There are four controls but some have different styles, it could be said that they are the main and most used. Each user control is independent of the other, so it does not require implementing the entire suite, of course this does not make it more optimal in code reduction, but it is that habit of not depending on anything, there are many lines of code and surely there will be more of some bugs turning, for my part I think that my desire with this reached here, of course if someone finds an error or suggestion, please inform us to correct it.

In the download you will find an example of each one and a main project that includes all and some additions to simulate a Dashboard.
Name:  DashBoard.jpg
Views: 55
Size:  32.4 KB

see more in http://leandroascierto.com/blog/charts-control-con-gdi
Attached Images
 
Attached Files

Planet Source Code Jumbo Resource CDs

$
0
0
This post is to provide a link to the Planet Source Code files. The link is basically the Google Drive portion of an alt Gmail account that I seldom use. In fact, prior to this, I wasn't using the Google Drive portion at all. And now, these PSC files are all that's out there.

Just as an FYI, I worked with Shaggy Hiker and FunkyDexter to get this going, and to stay within the TOS of VBForums.

This is basically the files from all the following CD mounted disks from PSC:

  • 1_2002.ISO
  • 2_2002-2004.ISO
  • 3_2004-2005.ISO
  • 4_2005-2006.ISO
  • 5_2007-2008.ISO
  • 6_2008-2009.ISO
  • 7_2009-2012.ISO

Regarding PSC uploads more recent than these, I've got no idea how to recover those. If someone does, I'd be delighted to include them with what I've got.

All of the PSC files within the mounted ISO files were converted to ZIP files. About 6 of the PSC files were corrupted, so those were not converted to ZIP files (and discarded).

Once this was done, all these ZIP files were scanned with Windows Defender. About 10 of the ZIP files were found to contain viruses. The specific files with viruses within the ZIP files were identified and deleted.

Then, all the ZIP files (and further nested ZIP files) were scanned for the existence of any of these file types:

  • EXE
  • DLL
  • OLB
  • OCX
  • OCA
  • OBJ
  • EX_
  • OC_
  • DL_

And, in all cases, those were deleted from the ZIP files (and from nested ZIPs).

At this point, what remained was mostly source code files, and some TXT files, and various garbage files like LOG, TMP, VBW. etc.

Even having done all of this, I take no responsibility for any of the contents of any of these files. Use at your own discretion.

Also, as a further note, when downloading VB6 source code, if it's got a VBW file, it's always advisable to delete this file as it's not needed, and has a small potential for causing harm.

Also, as with any source code you download, it's advisable to visually peruse it to make sure it's not doing anything you'd rather not do.

Here's the link.

The Notes.txt file is basically another copy of the text in this post.

The ZipFileIndex.tsv and ZipFileIndex.xlsx are files that index all the ZIP files in the AllThePscZipFilesZipped.zip file.

There are three columns in these index files:
  1. the ZIP file name
  2. the title from the @PSC file within the ZIP file
  3. the description from the @PSC file within the ZIP file

Just as an FYI, this represents 13,852 separate projects. However, many aren't worth much, but some of them are probably gems.

(VB6) source code of Add-In to delete *.vbw files on project load

(VB6) source code of Add-In to get IDE events

$
0
0
This Add-In provides sample code to demonstrate how to setup handlers for IDE events.

It is not intended to be used normally, but I'm posting it as a reference of source code needed to handle IDE events in an Add-In, for others that may need to handle IDE events.

What it does it to show a window that logs all the actions that have events set.

HTH to someone.
Attached Files

YemenRat open source

BoxShot 3D

$
0
0
Makes a box picture for your software and saves it as a bitmap.
Attached Images
 
Attached Files

Shut The Door(an old sailors game)

$
0
0
This is just a simple example of writing a game to pass the time. See what you think of it.
Attached Images
 

VB6 - Viewer

$
0
0
I used dilettante's Gossamer Web Server control to make an image viewer. The viewer is actually your browser, so in theory it will deliver anything that your browser will support; pictures, HTML, movies etc.

It is designed to run as a service using the NT Service Control, but will also run as a Desktop application. As provided, it runs as a Desktop application. To create the Service program, change the IsService flag to true and compile. To add it as a service, run the service program from the command prompt with a "/I" argument. If successful, a message "Viewer Service installed successfully." will display. To Uninstall it, use the "/U" argument. The Service Manager (services.msc) can then be used to start or stop the service. If you want to allow access from the Local Area Network (LAN), or the Wide Area Network (WAN), you will have to adjust your Firewall.

The Service logs service related functions to a date named file in the \Windows\System32\Logfiles\Misc directory. You should create this directory to utilize the Service function. Unlike the Desktop version, which logs individual access to the text box, the Service as provided does not log access.

As provided, the program uses a default Web page called "Default.htm" in the same directory as the executable. To access it, direct your browser to "localhost:8080". That web page will list 3 sub directories (HTML PAGES, PNG PICTURES, JPEG PICTURES). Simply click on one of them to access a listing of the available items. Clicking on one of them will display the particular item. To view another one, simply use the "Back" button on your browser.

The viewable items are located in 3 sub directories (\pages, \pngs, & \jpgs). I have provided a few samples as a separate download. The web page used to access these files is created automatically when it is selected from the default page. You do not have to manually add files to the HTML page. Simply copy your favorite images/pages to the appropriate directory. It is suggested that you change the name of the file to provide some meaning as to it's content, rather than generic names such as "Image(123).png". Web pages are not exactly my forte, so if there is a better way of doing this, I am all ears. I also anticipate that if wide access to these files is to be provided, some sort of limitation on the creation of the HTML pages will have to be provided for. Other than that potential problem, the speed of response on a local network seems very good.

I wanted to store the parameters in the registry, but the socket software is initialized in the User Control, which occurs before the form itself is run. I suppose the registry could be accessed from the User Control, but that will have to wait for a later version.

J.A. Coutts

Edit: The images would not upload. I suspect that it is too large. I will adjust them and upload later.
Attached Images
 
Attached Files

[VBA] Lambda Syntax - No script control or cheats! Happy for ports to VB6

$
0
0
Lambda Expressions

I've already posted this library elsewhere but figured that people on VBForums would find it useful too! This is currently only written to work in VBA but I believe a port to VB6 would only require the alteration of a few declarations. Or perhaps in quite a few within evaluateFunc... Happy to have pull requests if anyone wants to make it usable in VB6!

What is a lambda expression?

A lambda expression/anonymous function is a function definition that is not bound to a name. Lambda expressions are usually "1st class citezens" which means they can be passed to other functions for evaluation.

I personally believe this is best described with an example. Imagine we wanted to sort an array of sheets by their name. In VBA this would be relatively complex and require an understanding of how to sort data in the first place, as well as which algorithms to use. Lambda allows us to define 1 sorting function and then provide our lambda function to provide the ID to sort on:

Example.bas Code:
  1. Sub Main
  2.     myArray = Array(Sheets(1),Sheets(2))
  3.     newArray = sort(myArray, stdLambda.Create("$1.name"))
  4. End Sub
  5.  
  6. Function sort(array as variant, accessor as stdICallable)
  7.     '... sorting code ...
  8.        elementID = accessor(element)
  9.     '... sorting code ...
  10. End Function

Download

The file can be found on github here:
stdLambda.cls.

stdICallable will also be required: stdICallable.cls

How to use stdLambda

The Create() constructor is the main way to create an instance of the stdLambda object.

Example.bas Code:
  1. Sub test()
  2.     Dim cb as stdLambda
  3.     set cb = stdLambda.Create("1+1")
  4. End Sub

To define a function which takes multiple arguments $# should be used where # is the index of the argument. E.G. $1 is the first argument, $2 is the 2nd argument and $n is the nth argument.

Example.bas Code:
  1. Sub test()
  2.     Dim average as stdLambda
  3.     set average = stdLambda.Create("($1+$2)/2")
  4. End Sub

You can also define functions which call members of objects. Use xxx#xxx() to call functions and xxx.xxx() to call properties.

Example.bas Code:
  1. Sub test()
  2.     Debug.Print stdLambda.Create("$1.Name")(someObject)  'returns ThisWorkbook.Name
  3.     Call stdLambda.Create("$1#Save")(someObject)         'calls ThisWorkbook.Save
  4. End Sub

The lambda syntax comes with many VBA functions which you are already used to...

Example.bas Code:
  1. Sub test()
  2.     Debug.Print stdLambda.Create("Mid($1,1,5)")("hello world")        'returns "hello"
  3.     Debug.Print stdLambda.Create("$1 like ""hello*""")("hello world") 'returns true
  4. End Sub

As well as an inline if statement:

Example.bas Code:
  1. Sub test()
  2.     Debug.Print stdLambda.Create("if $1 then 1 else 2")(true)        'returns 1
  3.     Debug.Print stdLambda.Create("if $1 then 1 else 2")(false)       'returns 2
  4.  
  5.     'Note: this will only call someObj.CallMethod() and will not call someObj.CallMethod2() (unless 1st arg is supplied as false of course)
  6.     Debug.Print stdLambda.Create("if $1 then $2#CallMethod() else $2#CallMethod2()")(true,someObj)
  7. End Sub

With stdLambda you are not limited to a single lines, you can also use multiple lines. Note the result of the last line in the lambda is returned:

Example.bas Code:
  1. Call stdLambda.Create("2+2: 5*2").Run()
  2.  
  3. '... or ...
  4.  
  5. Call stdLambda.CreateMultiline(array( _
  6.   "2+2", _
  7.   "5*2", _
  8. )).Run()

You can also use variables, much like in VB6:

Example.bas Code:
  1. 'the last assignment is redundant, just used to show that assignments result in their value
  2. Debug.Print stdLambda.CreateMultiline(array( _
  3.   "count = $1", _
  4.   "footPrint = count * 2 ^ count" _
  5. )).Run(2) ' -> 8

Finally you can use Function definitions if you want to use recursion:

Example.bas Code:
  1. stdLambda.CreateMultiline(Array( _
  2.   "fun fib(v)", _
  3.   "  if v<=1 then", _
  4.   "    v", _
  5.   "  else ", _
  6.   "    fib(v-2) + fib(v-1)", _
  7.   "  end", _
  8.   "end", _
  9.   "fib($1)" _
  10. )).Run(20) '->6765

Evaluating lambdas

Use default member execution:

Example.bas Code:
  1. Sub test()
  2.     Dim average as stdLambda
  3.     set average = stdLambda.Create("($1+$2)/2")
  4.     Debug.Print average(1,2)   '1.5
  5. End Sub

Use Run method:

Example.bas Code:
  1. Sub test()
  2.     Dim average as stdLambda
  3.     set average = stdLambda.Create("($1+$2)/2")
  4.     Debug.Print average.Run(1,2)   '1.5
  5. End Sub

Use RunEx method, supplying an array of arguments:

Example.bas Code:
  1. Sub test()
  2.     Dim average as stdLambda
  3.     set average = stdLambda.Create("($1+$2)/2")
  4.     Debug.Print average.RunEx(Array(1,2))   '1.5
  5. End Sub

Sometimes it's useful to use an interface. In this case use stdICallable interface:

Example.bas Code:
  1. Sub test(ByVal func as stdICallable)
  2.     func.Run(ThisWorkbook, 1, "hello world")
  3. End Sub

An update as of 16/09/2020 added the Bind() method to stdLambda as well. The Bind() method creates a new ICallable that, when called, supplies the given sequence of arguments preceding any provided when the new function is called. This ultimately saves on expression compilation time.

Example.bas Code:
  1. 'Expression created, argument bound.
  2. Dim cb as stdLambda: set cb = stdLambda.Create("$1 + $2").Bind(5)
  3. Debug.Print cb(1) '6
  4. Debug.Print cb(2) '7
  5. Debug.Print cb(3) '8
  6.  
  7. 'No compilation required, cached lambda is used with new bound argument
  8. set cb = stdLambda.Create("$1 + $2").Bind(6)
  9. Debug.Print cb(1) '7
  10. Debug.Print cb(2) '8
  11. Debug.Print cb(3) '9

How it works

Finally, how does the class work internally?

Create first looks to see if a lambda already exists, if it does it is returned, else it calls Init which:
  • Tokenises the string using Regex
  • Calls parseBlock() which uses a top-down parsing algorithm to parse the entire block to an array/stack containing operations (i.e. compiles to byte code)


Then when an expression is executed, Run calls evaluate which:

  • Loops over all operations, detects the type and subtype of the operation
  • Performs the operations function
  • After all operations have executed the 1st item in the stack is returned.


Integration with the STD-VBA Library

Thought i'd give a taste of one of the core reasons I built this library!

Example.bas Code:
  1. 'Create an array
  2. Dim arr as stdArray
  3. set arr = stdArray.Create(1,2,3,4,5,6,7,8,9,10) 'Can also call CreateFromArray
  4.  
  5. 'More advanced behaviour when including callbacks! And VBA Lamdas!!
  6. Debug.Print arr.Map(stdLambda.Create("$1+1")).join          '2,3,4,5,6,7,8,9,10,11
  7. Debug.Print arr.Reduce(stdLambda.Create("$1+$2"))           '55 ' I.E. Calculate the sum
  8. Debug.Print arr.Reduce(stdLambda.Create("Max($1,$2)"))      '10 ' I.E. Calculate the maximum
  9. Debug.Print arr.Filter(stdLambda.Create("$1>=5")).join      '5,6,7,8,9,10
  10.  
  11. 'Execute property accessors with Lambda syntax
  12. Debug.Print arr.Map(stdLambda.Create("ThisWorkbook.Sheets($1)")) _
  13.                .Map(stdLambda.Create("$1.Name")).join(",")            'Sheet1,Sheet2,Sheet3,...,Sheet10
  14.  
  15. 'Execute methods with lambda:
  16. Call stdArray.Create(Workbooks(1),Workbooks(2)).forEach(stdLambda.Create("$1#Save")
  17.  
  18. 'Sort objects by date, and then print names concatenated with comma
  19. Debug.Print stdArray.Create(ObjA,ObjB,ObjC,ObjD,ObjE).sort(stdLambda.Create("$1.Date")).map(stdLambda.Create("$1.Name")).join(",")
  20.  
  21. 'We even have if statement!
  22. With stdLambda.Create("if $1 then ""lisa"" else ""bart""")
  23.   Debug.Print .Run(true)                                              'lisa
  24.   Debug.Print .Run(false)                                             'bart
  25. End With


Long term goals

The intermediate representation is good, but it would be even better if we could compile to machine code... I'm pretty sure this is even more difficult, but in the pursuit of speed that's maybe where we'll have to go!

Happy Coding!
~Sancarn

RtlToFromString - Number Bases

$
0
0
For the most part we're already set for converting to/from number bases in VB6. But sometimes people want something more.

Here is a little bit more based upon two API calls:

  • RtlInt64ToUnicodeString()
  • RtlUnicodeStringToInteger()


Bases:

  • Binary (2)
  • Octal (8)
  • Decimal (10)
  • Hex (16)


This wrapper code supports a number of numeric data types.

FromString():

  • Byte
  • Integer
  • Long
  • Single


ToString():

  • Byte
  • Integer
  • Long
  • Single
  • Double
  • Date
  • Currency


ToString() will optionally pad with 0's on the left to fill out the full precision of the input numeric data type (32 bits for Long, etc.). By default leading 0's are suppressed.

FromString() can be told what base to convert explicitly, or the input text can use a leading prefix (like "0x" for Hex) to indicate the base. An optional + or - sign can also be used in the input text.


Tests:

Code:

    Dim B As Byte

    Report "------------------ FromString ----------------------"
    Report """-123""", "In Default", FromString("-123")
    Report """0b1111""", "In Default", FromString("0b1111", vbByte)
    Report """  +1111""", "In Binary", FromString("  +1111", vbByte, fmtBinary)
    Report """-b""", "In Hex", FromString("-b", vbInteger, fmtHex)
    Report "------------------- ToString -----------------------"
    B = 254
    Report "From Byte:"
    Report B, "Out Default", ToString(B)
    Report B, "Out Dec", ToString(B, fmtDecimal)
    Report B, "Out Hex", ToString(B, fmtHex)
    Report B, "Out Binary", ToString(B, fmtBinary)
    Report "From Integer:"
    Report 32767, "Out Dec", ToString(32767, fmtDecimal)
    Report 32767, "Out Hex", ToString(32767, fmtHex)
    Report 32767, "Out Binary", ToString(32767, fmtBinary)
    Report "From Long:"
    Report 32767&, "Out Dec", ToString(32767&, fmtDecimal)
    Report 32767&, "Out Oct pad", ToString(32767&, fmtOctal, True)
    Report 32767&, "Out Hex pad", ToString(32767&, fmtHex, True)
    Report 32767&, "Out Binary pad", ToString(32767&, fmtBinary, True)
    Report -65535, "Out Dec", ToString(-65535, fmtDecimal)
    Report -65535, "Out Hex", ToString(-65535, fmtHex)
    Report -65535, "Out Binary", ToString(-65535, fmtBinary)
    Report "From Double:"
    Report 1.123, "Out Dec", ToString(1.123, fmtDecimal)
    Report 1.123, "Out Hex", ToString(1.123, fmtHex)
    Report 1.123, "Out Binary", ToString(1.123, fmtBinary)
    Report "From Currency:"
    Report 0.0254@, "Out Dec", ToString(0.0254@, fmtDecimal)
    Report 0.0254@, "Out Hex", ToString(0.0254@, fmtHex)
    Report 0.0254@, "Out Binary pad", ToString(0.0254@, fmtBinary, True)

Results:

Code:

------------------ FromString ----------------------
"-123"        In Default    -123
"0b1111"      In Default    15
"  +1111"      In Binary      15
"-b"          In Hex        -11
------------------- ToString -----------------------
From Byte:
254            Out Default    254
254            Out Dec        254
254            Out Hex        FE
254            Out Binary    11111110
From Integer:
32767          Out Dec        32767
32767          Out Hex        7FFF
32767          Out Binary    111111111111111
From Long:
32767          Out Dec        32767
32767          Out Oct pad    00000077777
32767          Out Hex pad    00007FFF
32767          Out Binary pad 00000000000000000111111111111111
-65535        Out Dec        4294901761
-65535        Out Hex        FFFF0001
-65535        Out Binary    11111111111111110000000000000001
From Double:
1.123          Out Dec        4607736361554183979
1.123          Out Hex        3FF1F7CED916872B
1.123          Out Binary    11111111110001111101111100111011011001000101101000011100101011
From Currency:
0.0254        Out Dec        254
0.0254        Out Hex        FE
0.0254        Out Binary pad 0000000000000000000000000000000000000000000000000000000011111110

You could easily write your own wrappers for these API calls if you don't like these.
Attached Files

Windows Logo Glyph

$
0
0
Not sure why you'd ever need it, but I stumbled across this:

Name:  sshot.png
Views: 60
Size:  571 Bytes

Code:

Option Explicit

Private Sub Form_Load()
    With Label1
        .BackColor = vbHighlightText
        .ForeColor = vbHighlight
        .Caption = "W"
        With .Font
            .Name = "Marlett"
            .Size = 20
        End With
    End With
End Sub

That gets you a character "icon" of the Windows Logo. I would expect the appearance to vary somewhat on different Windows versions, and I'm not sure when this glyph was added to Marlett.
Attached Images
 

How to print the information posted on the CwVList object (Included in the VbWidgets

$
0
0
Hello the community I have a large concern which requires of assistance of the examples, right knowledge how to print the information posted on the CwVList object (Included in the VbWidgets library in conjunction with (RC5)?
I would like to know if there is the possibility of printing the data posted on cwVList, myself I tested, but I do not find the way short, yours assistances of use will be the welcome, and I would appreciate of the assistance come to Olaf its would relieve me,

[VB6 Add-In] Project Examiner

$
0
0
Updated again!

This project is still undergoing adjustments and maybe bug fixes if they are.
The changelog is posted at the bottom.
If you have anything to suggest or want to report a bug or would like some feature to be added please report/comment. (Images are not supported to be handled by Add-Ins, I placed a note below)


Note: It is always recommended to have an up-to-date backup of the projects, especially when using new tools.

This Add-In is mainly intended for large projects, maybe old or inherited projects that you need to renew or rework, and you have to find what it has and where.

It deals with design time issues, not with source code. For source code I suggest LaVolpe's Project Scanner.

How to start with it:

Download the source code of the Add-In, compile it with an elevated IDE and close the IDE.

Then open the IDE again with the project you want to work on.
Go to the Add-Ins menu and select Project Examiner.

Here there are some screen shots:

Name:  PE1.png
Views: 148
Size:  10.5 KB

Name:  PE4.png
Views: 145
Size:  10.5 KB

Name:  PE6.png
Views: 146
Size:  14.5 KB

There are several tabs. Their functions are:

Scan:
Performs the scan of the project to find what it has.
This must be done before anything else.

Dependencies:
Shows what control types the program uses and where they are.
There are two option buttons at the bottom to select to view them grouped by dependency or by form.

Strings:
Shows what controls and which properties has strings stored at design time.
This can be useful if you are translating a program and need to find where are the design-time strings that need translation.

Fonts:
This tab shows the fonts that the program uses and where.
There are two option buttons at the bottom to select to view them grouped by font or by form.

Find controls:
Find the controls that meet certain criteria. The condition is the value of a property ("=", "<>" ">", etc.).
If works with numeric values and also with strings.

Replace fonts:
There you can select what font to replace and with which one.

Copy controls:
Copy a control that is on a form to all the others (and/or to usercontrols) or some of them.

Note: Image handling seems not to be supported by the Add-in environment.

Changelog:

Code:

2020-10-04c: Update:
      The Copy to Clipboard feature now adds tab characters instead of spaces to facilitate pasting to Excel.
      Some forms can be flagged unsaved (or changed) just opening them (without making any changes to them). It can be due to an UserControl or third party control. The Add-in opens all the forms, and in the previous version these forms were flagged as unsaved. Now that is fixed in this version, all forms remain in their original "saved/unsaved" state.
      Designer windows remain in their original state (not closed if they were already open).
2020-10-04b: Update:
      The compare criteria in the Find tab now ignored the "&" symbol (that can be common on Captions to set the accelerator key)
      FontName properties not added to the String list anymore.
      Out of memory bug fixed. The designer windows were opened -but not set visible- in the scan and not closed after that, causing an out of memory error on very large projects.
2020-10-03: First version

Attached Images
   
Attached Files

[VB6] DirectX 11 Desktop Duplication

$
0
0
This is a work in progress of a remote control utility. This is the screen capturing part using DirectX 11 (DXGI).

Code:

Option Explicit

'--- DIB Section constants
Private Const DIB_RGB_COLORS                As Long = 0 '  color table in RGBs

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, lpBits As Long, ByVal Handle As Long, ByVal dw As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long

Private Type BITMAPINFOHEADER
    biSize              As Long
    biWidth            As Long
    biHeight            As Long
    biPlanes            As Integer
    biBitCount          As Integer
    biCompression      As Long
    biSizeImage        As Long
    biXPelsPerMeter    As Long
    biYPelsPerMeter    As Long
    biClrUsed          As Long
    biClrImportant      As Long
End Type

Private Type PICTDESC
    lSize              As Long
    lType              As Long
    hBmp                As Long
    hPal                As Long
End Type

Private Type UcsDuplicationContext
    DeviceName          As String
    Width              As Long
    Height              As Long
    pContext            As ID3D11DeviceContext
    pStageTexture      As ID3D11Texture2D
    pDuplication        As IDXGIOutputDuplication
    pTexture            As ID3D11Texture2D
End Type

Private m_uCtx                  As UcsDuplicationContext

Private Sub PrintError(sFuncName As String)
    Debug.Print Err.Description & " in " & sFuncName
    If MsgBox(Err.Description, vbCritical Or vbOKCancel, sFuncName) = vbCancel Then
        Unload Me
    End If
End Sub

Private Function pvEnumOutputDeviceNames() As Collection
    Dim aGUID(0 To 3)  As Long
    Dim pFactory        As IDXGIFactory1
    Dim lIdx            As Long
    Dim lJdx            As Long
    Dim pAdapter        As IDXGIAdapter1
    Dim pOutput        As IDXGIOutput1
    Dim uAdapterDesc    As DXGI_ADAPTER_DESC
    Dim uOutputDesc    As DXGI_OUTPUT_DESC
   
    Set pvEnumOutputDeviceNames = New Collection
    Call IIDFromString(szIID_DXGIFactory1, aGUID(0))
    Set pFactory = CreateDXGIFactory1(aGUID(0))
    For lIdx = 0 To 100
        Set pAdapter = Nothing
        If pFactory.EnumAdapters1(lIdx, pAdapter) <> 0 Then
            Exit For
        End If
        pAdapter.GetDesc uAdapterDesc
        Debug.Print Replace(uAdapterDesc.Description, vbNullChar, vbNullString)
        For lJdx = 0 To 100
            Set pOutput = Nothing
            If pAdapter.EnumOutputs(lJdx, pOutput) <> 0 Then
                Exit For
            End If
            pOutput.GetDesc uOutputDesc
            pvEnumOutputDeviceNames.Add Array(Replace(uOutputDesc.DeviceName, vbNullChar, vbNullString), _
                Replace(uAdapterDesc.Description, vbNullChar, vbNullString))
        Next
    Next
End Function

Private Function pvInitCapture(uCtx As UcsDuplicationContext, sDeviceName As String) As Boolean
    Const FUNC_NAME    As String = "pvInitCapture"
    Dim aGUID(0 To 3)  As Long
    Dim pFactory        As IDXGIFactory1
    Dim lIdx            As Long
    Dim lJdx            As Long
    Dim pAdapter        As IDXGIAdapter1
    Dim pOutput        As IDXGIOutput1
    Dim uOutputDesc    As DXGI_OUTPUT_DESC
    Dim hResult        As Long
    Dim pDevice        As ID3D11Device
    Dim uTextureDesc    As D3D11_TEXTURE2D_DESC
   
    On Error GoTo EH
    With uCtx
        .DeviceName = vbNullString
        Set .pTexture = Nothing
        Set .pDuplication = Nothing
        Set .pStageTexture = Nothing
        Set .pContext = Nothing
        Call IIDFromString(szIID_DXGIFactory1, aGUID(0))
        Set pFactory = CreateDXGIFactory1(aGUID(0))
        For lIdx = 0 To 100
            Set pAdapter = Nothing
            If pFactory.EnumAdapters1(lIdx, pAdapter) <> 0 Then
                Exit For
            End If
            For lJdx = 0 To 100
                Set pOutput = Nothing
                If pAdapter.EnumOutputs(lJdx, pOutput) <> 0 Then
                    Exit For
                End If
                pOutput.GetDesc uOutputDesc
                If Replace(uOutputDesc.DeviceName, vbNullChar, vbNullString) Like sDeviceName Or LenB(sDeviceName) = 0 Then
                    lIdx = 100
                    Exit For
                End If
            Next
        Next
        If pOutput Is Nothing Then
            GoTo QH
        End If
        .DeviceName = Replace(uOutputDesc.DeviceName, vbNullChar, vbNullString)
        .Width = uOutputDesc.DesktopCoordinates.Right - uOutputDesc.DesktopCoordinates.Left
        .Height = uOutputDesc.DesktopCoordinates.Bottom - uOutputDesc.DesktopCoordinates.Top
        hResult = D3D11CreateDevice(pAdapter, D3D_DRIVER_TYPE_UNKNOWN, 0, 0, ByVal 0, 0, D3D11_SDK_VERSION, pDevice, 0, .pContext)
        If hResult < 0 Then
            Err.Raise hResult
        End If
        With uTextureDesc
            .Width = uCtx.Width
            .Height = uCtx.Height
            .MipLevels = 1
            .ArraySize = 1
            .Format = DXGI_FORMAT_B8G8R8A8_UNORM
            .SampleDesc.Count = 1
            .SampleDesc.Quality = 0
            .Usage = D3D11_USAGE_STAGING
            .BindFlags = 0
            .CPUAccessFlags = D3D11_CPU_ACCESS_READ
            .MiscFlags = 0
        End With
        Set .pStageTexture = pDevice.CreateTexture2D(uTextureDesc)
        Set .pDuplication = pOutput.DuplicateOutput(pDevice)
    End With
    '--- success
    pvInitCapture = True
QH:
    Exit Function
EH:
    PrintError FUNC_NAME
End Function

Private Function pvCaptureScreen(uCtx As UcsDuplicationContext, oPic As StdPicture) As Boolean
    Const FUNC_NAME    As String = "pvCaptureScreen"
    Dim hResult        As Long
    Dim aGUID(0 To 3)  As Long
    Dim lIdx            As Long
    Dim uFrameInfo      As DXGI_OUTDUPL_FRAME_INFO
    Dim uResource      As D3D11_MAPPED_SUBRESOURCE
    Dim hMemDC          As Long
    Dim hDib            As Long
    Dim lpBits          As Long
    Dim uDesc          As PICTDESC
    Dim uDuplDesc      As DXGI_OUTDUPL_DESC
    Dim uMapRect        As DXGI_MAPPED_RECT
   
    On Error GoTo EH
    With uCtx
        If .pDuplication Is Nothing Then
            GoTo QH
        End If
        If Not .pTexture Is Nothing Then
            .pDuplication.ReleaseFrame
            Set .pTexture = Nothing
        End If
        hResult = .pDuplication.AcquireNextFrame(100, uFrameInfo, .pTexture)
        If hResult < 0 Then
            GoTo QH
        End If
        hMemDC = CreateCompatibleDC(0)
        If hMemDC = 0 Then
            GoTo QH
        End If
        If Not pvCreateDib(hMemDC, .Width, .Height, hDib, lpBits) Then
            GoTo QH
        End If
        .pDuplication.GetDesc uDuplDesc
        If uDuplDesc.DesktopImageInSystemMemory <> 0 Then
            .pDuplication.MapDesktopSurface uMapRect
            For lIdx = 0 To .Height - 1
                Call CopyMemory(ByVal lpBits + lIdx * .Width * 4, ByVal uMapRect.pBitsPtr + lIdx * uMapRect.Pitch, .Width * 4)
            Next
        Else
            .pContext.CopyResource .pStageTexture, .pTexture
            .pContext.Map .pStageTexture, 0, D3D11_MAP_READ, 0, uResource
            For lIdx = 0 To .Height - 1
                Call CopyMemory(ByVal lpBits + lIdx * .Width * 4, ByVal uResource.pDataPtr + lIdx * uResource.RowPitch, .Width * 4)
            Next
        End If
    End With
    With uDesc
        .lSize = Len(uDesc)
        .lType = vbPicTypeBitmap
        .hBmp = hDib
    End With
    '--- IID_IPicture
    aGUID(0) = &H7BF80980
    aGUID(1) = &H101ABF32
    aGUID(2) = &HAA00BB8B
    aGUID(3) = &HAB0C3000
    If OleCreatePictureIndirect(uDesc, aGUID(0), 1, oPic) <> 0 Then
        GoTo QH
    End If
    hDib = 0
    '--- success
    pvCaptureScreen = True
QH:
    If hDib <> 0 Then
        Call DeleteObject(hDib)
        hDib = hDib
    End If
    If hMemDC <> 0 Then
        Call DeleteDC(hMemDC)
        hMemDC = 0
    End If
    If uResource.pDataPtr <> 0 Then
        uCtx.pContext.Unmap uCtx.pStageTexture, 0
    End If
    Exit Function
EH:
    PrintError FUNC_NAME
    Resume QH
End Function

Private Function pvCreateDib(ByVal hMemDC As Long, ByVal lWidth As Long, ByVal lHeight As Long, hDib As Long, Optional lpBits As Long) As Boolean
    Const FUNC_NAME    As String = "pvCreateDib"
    Dim uHdr            As BITMAPINFOHEADER
   
    On Error GoTo EH
    With uHdr
        .biSize = Len(uHdr)
        .biPlanes = 1
        .biBitCount = 32
        .biWidth = lWidth
        .biHeight = -lHeight
        .biSizeImage = 4 * lWidth * lHeight
    End With
    hDib = CreateDIBSection(hMemDC, uHdr, DIB_RGB_COLORS, lpBits, 0, 0)
    If hDib = 0 Then
        GoTo QH
    End If
    '--- success
    pvCreateDib = True
QH:
    Exit Function
EH:
    PrintError FUNC_NAME
    Resume QH
End Function

Private Sub Form_Load()
    Dim vElem          As Variant
   
    For Each vElem In pvEnumOutputDeviceNames
        Combo1.AddItem vElem(0)
    Next
    Combo1.ListIndex = 0
End Sub

Private Sub Form_Resize()
    Dim dblTop          As Double
   
    If WindowState <> vbMinimized Then
        dblTop = Combo1.Top + Combo1.Height + Combo1.Top
        Image1.Move 0, dblTop, ScaleWidth, ScaleHeight - dblTop
    End If
End Sub

Private Sub Combo1_Click()
    If Combo1.ListIndex >= 0 Then
        If Not pvInitCapture(m_uCtx, Combo1.Text) Then
            Timer1.Enabled = False
        Else
            Timer1.Enabled = True
            Timer1_Timer
        End If
    End If
End Sub

Private Sub Image1_Click()
    Timer1.Enabled = Not Timer1.Enabled
End Sub

Private Sub Timer1_Timer()
    Dim oPic            As StdPicture
   
    If pvCaptureScreen(m_uCtx, oPic) Then
        Set Image1.Picture = oPic
    ElseIf Not pvInitCapture(m_uCtx, m_uCtx.DeviceName) Then
        Timer1.Enabled = False
    End If
End Sub

There is a custom DirectX 11 type library (both .idl and .tlb in the archive) with just enough interfaces to instantiate IDXGIOutputDuplication and capture a texture which is then converted to a DIB which is then converted to a StdPicture and placed in a stretching Image control so the scale quality is poor.

The idea is for a remote screen sharing implementation to transport only screen diffs using GetFrameDirtyRects, GetFrameMoveRects and GetFramePointerShape methods (instead of current full screen capture) with some fast LZ4 compression on top and some Foreward Error Correction implementation over UDP, including UDP hole punching for serverless peer-to-peer connections when both parties happen to be behind NAT or alternative is using STUN/TURN infrastructure as currently provided by google for WebRTC.

cheers,
</wqw>
Attached Files

VB6 MDB-RemoteAccess via http(s)

$
0
0
Just a small Demo, which shows how to setup these kind of remote-services and -requests in as simple a manner as possible, using:
- a small WebServer of course, to get serverside http-protocol-support (here, cWebServer from the vbRichClient5-lib is used)
- a clientside http-COMponent (here, the MS-WinHttp-5.1 Object will be used)
- a transport-container-Object, which can be serialized to and from ByteArrays (we talk about ADODB.Recordsets here)
- and finally a simple RPC-call-scheme, which describes the serverside MDB-File in the http-URL - and the SQL-Select-String in the http-Body
..(then always returning an ADODB.Recordset, also in case of any Server- or Clientside Error)

All this is packed into a quite small CodeBase, which should be easy enough to study+understand.
Later "upgrading" to a "larger WebServer" (e.g. the MS-Internet-Information-Server, aka "IIS") can be done without much fuss,
e.g. from what I've already described here: https://www.vbforums.com/showthread....g-of-http-RPCs

The App looks this way:


And the Project-Source-Code is here:
MDBServer.zip

HTH

Olaf
Attached Files

Here's how to play an Integer array as sound.

$
0
0
This code should be added to a module, and then called from wherever you need it. It plays 16bit audio from any one-dimensional Integer array with an LBound of 0.

Code:

Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByRef lpszName As Any, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Private Declare Sub vbaCopyBytes Lib "msvbvm60.dll" Alias "__vbaCopyBytes" (ByVal ByteCount As Long, ByRef Dest As Any, ByRef Src As Any)

Private Const SND_ASYNC As Long = &H1
Private Const SND_MEMORY As Long = &H4
Private Const SND_LOOP As Long = &H8

Private Type RiffHeader
    ID As Long
    Size As Long
    FileFormat As Long
End Type
Private Type FormatHeader
    ID As Long
    Size As Long
    AudioFormat As Integer
    NumChannels As Integer
    SR As Long
    ByteRate As Long
    BytesPerSample As Integer
    BitsPerChannel As Integer
End Type
Private Type DataHeader
    ID As Long
    Size As Long
End Type

Public Sub PlayWave(ByRef Wave() As Integer, Optional ByVal SR As Long = 48000, Optional ByVal LoopSound As Boolean, Optional ByVal WaitTillPlayFinished As Boolean)
    Dim Flags As Long
    Dim WavFile() As Byte
    Dim RH As RiffHeader
    Dim FH As FormatHeader
    Dim DH As DataHeader
   
    Flags = SND_MEMORY
    If WaitTillPlayFinished = False Then Flags = Flags Or SND_ASYNC
    If LoopSound Then Flags = Flags Or SND_LOOP
   
   
    DH.ID = &H61746164
    DH.Size = (UBound(Wave) + 1) * 2
   
    With FH
        .ID = &H20746D66
        .Size = LenB(FH) - 8
        .AudioFormat = 1
        .NumChannels = 1
        .SR = SR
        .BitsPerChannel = 16
        .BytesPerSample = (.BitsPerChannel \ 8) * .NumChannels
        .ByteRate = .SR * .BytesPerSample
    End With
    RH.ID = &H46464952
    RH.Size = DH.Size + 8 + FH.Size + 8 + 4
    RH.FileFormat = &H45564157

    ReDim WavFile(RH.Size + 8 - 1)
    vbaCopyBytes LenB(RH), WavFile(0), RH
    vbaCopyBytes LenB(FH), WavFile(LenB(RH)), FH
    vbaCopyBytes LenB(DH), WavFile(LenB(RH) + LenB(FH)), DH
    vbaCopyBytes DH.Size, WavFile(LenB(RH) + LenB(FH) + LenB(DH)), Wave(0)
   
    PlaySound WavFile(0), 0, Flags
End Sub

Public Sub StopWave()
    PlaySound ByVal 0&, 0, 0
End Sub

The only public elements are the PlayWave and StopWave subs, so all the functionality you need are in those.
PlayWave parameters are:
Wave() which is an Integer array that contains the sound waveform that you want to play. It's the only required field.
SR which is the sample rate, and it defaults to 48000 if you don't set it.
LoopSound which is a boolean value. If true, the sound repeats indefinitely. You will need to call the StopWave sub to get it to stop playing. Otherwise it just plays through once. Default = False
WaitTillPlayFinished is a boolean value. If true, the sound playing will be a blocking operation. That is, the rest of your code won't execute until the sound has finished playing. Otherwise it will keep playing while the rest of your code executes. Default = false.

Note that LoopSound and WaitTillPlayFinished are mutually exclusive. You can't use them simultaneously. If you could, your program would lock up and keep playing the sound forever. To prevent this, the Windows API function that my sub calls is designed to not let this combination be used. However, instead of refusing to play at all, it seems that synchronous play flag simply overrides the looping flag, meaning that it will behave as if the synchronous play flag were set, and the looping flag is not set. Thus it will play the sound, instead of not playing, but the sound playing will be a blocking operation.

The PlayWave sub has no parameters. You need to call it to stop the sound playing if you are playing on a loop. Also it will stop a really long sound playing early (even if looping isn't enabled), if it is called before the sound has finished playing.

VB6 WebView2-Binding (Edge-Chromium)

$
0
0
Have just finished a Binding to the new WebView2-BrowserControl (based on Edge-Chromium).

I've included this Binding (all in a single Class, named cWebView2) in the new RC6-version of the RichClient-lib
(please download this new version 6 from its usual place, at vbRichClient.com first).

The new BaseDll-package of the RC6 now includes the official WebView2Loader.dll (version 1.0.674),
which the cWebView2-class then works against.

Please note, that the above Binding will currently require, that you install the larger:
"Evergreeen WebView2-Runtime" (not included in the RC6-BasePackage).
Here the official MS-DownloadLink for the evergreen-installer: https://go.microsoft.com/fwlink/p/?LinkId=2124703

So, after ensuring the mentioned two prerequisites:
- the Dlls of the new RC6-package in a folder of your choice + a registered RC6.dll
- and the successfull installation of the "evergreen-WebView2-runtime" via the MS-download-link above

You should now be able to test this new Edge-Browser-Binding (even on Win7-OSes) via this little VB6-Demo:
WebView2Demo.zip

Please let me know, when something is not working as expected -
or when you want me to include a certain extra-functionality into the new cWebView2-class.

I want to "finalize" the new RC6-functionality at the end of the year (then switching Binary-Compatibility on).

Happy testing... :)

Olaf
Attached Files

XmlMono Class

$
0
0
I am working on some exports from Autodesk Inventor, as xlsx files. So I start to program in Vb6 to make something to handle these xlsx files (without using excel as object). To read xml files from xlsx I get the cZipArchive from wqweto. Works fine, without leaks. I can't say the same for the msxml2. I do a test of opening 100 times two xml files, (one for geting the strings, because strings are separete from sheet), and at 25 iteration, I got a message no other memory for threads. So I turn the other way to implement the same functionality if i could.
This is my work, and have no leaks, 100X100 times or more, no problem.
There is one module with the test program, and the class.

You can make it whatever you want. No load or save to file. One class make the tree. There are collections for siblings. Also the node is a variant array inside the tree.


Code:

test
 3
69
70
71
69            element
codename      VB6
sold          2
70            element
codename      C++
sold          3
71            element
codename      M2000
sold          10
beautify -2
<?xml version="1.0" encoding="UTF16"?>
<names>
  <element id="69">
      <codename>VB6</codename>
      <sold>2</sold>
  </element>
  <element id="70" Nobel="yes">
      <codename><![CDATA[C++]]></codename>
      <sold>3</sold>
  </element>
  <element id="71">
      <codename>M2000</codename>
      <sold>10</sold>
  </element>
</names>


beautify 4
    <?xml version="1.0" encoding="UTF16"?>
    <names>
        <element id="69">
            <codename>VB6</codename>
            <sold>2</sold>
        </element>
        <element id="70" Nobel="yes">
            <codename><![CDATA[C++]]></codename>
            <sold>3</sold>
        </element>
        <element id="71">
            <codename>M2000</codename>
            <sold>10</sold>
        </element>
    </names>


L.Xml = k.Xml


Print L.Xml
<?xml version="1.0" encoding="UTF16"?>
<names>
    <element id="69">
        <codename>VB6</codename>
        <sold>2</sold>
    </element>
    <element id="70" Nobel="yes">
        <codename><![CDATA[C++]]></codename>
        <sold>3</sold>
    </element>
    <element id="71">
        <codename>M2000</codename>
        <sold>10</sold>
    </element>
</names>




I found it
<sold>2</sold>
Get a list of all nodes with same tag
 1            VB6
 2            C++
 3            M2000

Attached Files
Viewing all 1542 articles
Browse latest View live


<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>