Quantcast
Channel: VBForums - CodeBank - Visual Basic 6 and earlier
Viewing all 1461 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: 264
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: 331
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.

There are also files out there named PscDatabase.mdb and AllThePscPictures.zip. The PscDatabase.mdb is just the original PSC database. There is no code in this file. It's just the tables from the original PSC database. The AllThePscPictures.zip is just all the pictures from the CDs (GIFs and JPGs only) all zipped into one zip file. Using the database, there is a way to relate these pictures to their respective projects, but you're on your own regarding that.

---------------
Changes:

Sept 14, 2020: The PscDatabase.mdb I originally had out there wasn't the one from the 7th (last) CD. These databases were cumulative, so the one from the 7th CD should have everything. I changed the database in the link to be this 7th (last) database. It was also checked, and it contains no code. Also, the empty Bookmark and UseCount tables were just deleted from it. There were also two strange queries in it, and I deleted those as well.

Sept 15, 2020: Added three new files: NewerZipFilesZipped.zip, NewerZipFileIndex.tsv, & NewerZipFileIndex.xlsx. All the ZIP files in NewerZipFilesZipped.zip went through the same rigorous process of the original ZIP files (scanned for viruses (none found) and all binaries deleted (including inside nested ZIP files)). The index files are organized exactly like the others. These are 333 projects from PSC since 2012 in these files. They were contributed by a source who prefers to stay anonymous.

(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.
Updated with a few additions.
Attached Images
 
Attached Files

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). 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. VbForums now says that I have exceeded my limit?
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: 78
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
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: 184
Size:  10.5 KB

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

Name:  PE6.png
Views: 179
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.


Notes:
  • Image handling seems not to be supported by the Add-in environment.
  • Make a backup copy of your project before doing anything (if you don't already have one), that is a good practice.

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
DefObj A-Z

#Const SHOW_DELTA = False
#Const STRETCH_POINTER = False

'=========================================================================
' API
'=========================================================================

'--- DIB Section constants
Private Const DIB_RGB_COLORS                                As Long = 0 '  color table in RGBs
'--- for OpenInputDesktop
Private Const GENERIC_READ                                  As Long = &H80000000
'--- for SetProcessDpiAwarenessContext
Private Const DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE_V2    As Long = -4
'--- for D3DKMTSetProcessSchedulingPriorityClass
Private Const D3DKMT_SCHEDULINGPRIORITYCLASS_REALTIME      As Long = 5

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 Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Private Declare Function OpenInputDesktop Lib "user32" (ByVal dwFlags As Long, ByVal fInherit As Boolean, ByVal dwDesiredAccess As Long) As Long
Private Declare Function CloseDesktop Lib "user32" (ByVal hDesktop As Long) As Long
Private Declare Function SetThreadDesktop Lib "user32" (ByVal hDesktop As Long) As Long
Private Declare Function SetProcessDpiAwarenessContext Lib "user32" (ByVal lValue As Long) As Long
Private Declare Function D3DKMTSetProcessSchedulingPriorityClass Lib "gdi32" (ByVal hProcess As Long, ByVal lPriority As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () 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

'=========================================================================
' Constants and mamber variables
'=========================================================================

Private m_uCtx                  As UcsDuplicationContext
Private m_uFrame                As UcsCaptureFrame

Private Type UcsDuplicationContext
    DeviceName          As String
    Width              As Long
    Height              As Long
    Timeout            As Long
    Context            As ID3D11DeviceContext
    Duplication        As IDXGIOutputDuplication
    StageTexture        As ID3D11Texture2D
    DesktopResource    As ID3D11Resource
    InSystemMemory      As Boolean
    Pitch              As Long
    Stride              As Long
    DesktopPicture      As StdPicture
    DesktopBitsPtr      As Long
    PointerPicture      As StdPicture
    PointerBitsPtr      As Long
End Type

Private Type UcsCaptureFrame
    NumMoveRects        As Long
    MoveRects()        As DXGI_OUTDUPL_MOVE_RECT
    NumDirtyRects      As Long
    DirtyRects()        As D3D11_RECT
    PointerSize        As Long
    PointerShape()      As Byte
    PointerVisible      As Boolean
    PointerPlacement    As D3D11_RECT
    PointerHotspot      As D3D11_POINT
End Type

'=========================================================================
' Error handling
'=========================================================================

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

'=========================================================================
' Methods
'=========================================================================

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, ByVal sDeviceName As String, ByVal lTimeout As Long) As Boolean
    Const FUNC_NAME    As String = "pvInitCapture"
    Dim hDesktop        As Long
    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 pOutput5        As IDXGIOutput5
    Dim uOutputDesc    As DXGI_OUTPUT_DESC
    Dim hResult        As Long
    Dim pD3D11Device    As ID3D11Device
    Dim pDXGIDevice    As IDXGIDevice1
    Dim uTextureDesc    As D3D11_TEXTURE2D_DESC
    Dim uDuplDesc      As DXGI_OUTDUPL_DESC
    Dim uResource      As D3D11_MAPPED_SUBRESOURCE
   
    On Error GoTo EH
    '--- allow capture the secure desktop
    hDesktop = OpenInputDesktop(0, 0, GENERIC_READ)
    If hDesktop <> 0 Then
        Call SetThreadDesktop(hDesktop)
        Call CloseDesktop(hDesktop)
    End If
    On Error Resume Next '--- Windows 10, version 1703 and above
    Call SetProcessDpiAwarenessContext(DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE_V2)
    On Error GoTo EH
    With uCtx
        .DeviceName = vbNullString
        Set .DesktopResource = Nothing
        Set .Duplication = Nothing
        Set .StageTexture = Nothing
        Set .Context = Nothing
        Set .DesktopPicture = Nothing
        Set .PointerPicture = Nothing
        Call IIDFromString(szIID_DXGIFactory1, aGUID(0))
        Set pFactory = CreateDXGIFactory1(aGUID(0))
        For lIdx = 0 To 100
            Set pAdapter = Nothing
            hResult = pFactory.EnumAdapters1(lIdx, pAdapter)
            If hResult = DXGI_ERROR_NOT_FOUND Then
                Exit For
            End If
            If hResult < 0 Then
                Err.Raise hResult, "IDXGIFactory1.EnumAdapters1"
            End If
            For lJdx = 0 To 100
                Set pOutput = Nothing
                hResult = pAdapter.EnumOutputs(lJdx, pOutput)
                If hResult = DXGI_ERROR_NOT_FOUND Then
                    Exit For
                End If
                If hResult < 0 Then
                    Err.Raise hResult, "IDXGIAdapter1.EnumOutputs"
                End If
                pOutput.GetDesc uOutputDesc
                If LenB(sDeviceName) <> 0 And Not Replace(uOutputDesc.DeviceName, vbNullChar, vbNullString) Like sDeviceName Then
                    GoTo Continue
                End If
                If uOutputDesc.AttachedToDesktop <> 0 Then
                    lIdx = 100
                    Exit For
                End If
Continue:
            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
        .Timeout = lTimeout
        hResult = D3D11CreateDevice(pAdapter, D3D_DRIVER_TYPE_UNKNOWN, 0, D3D11_CREATE_DEVICE_VIDEO_SUPPORT, ByVal 0, 0, D3D11_SDK_VERSION, pD3D11Device, 0, .Context)
        If hResult < 0 Then
            Err.Raise hResult, "D3D11CreateDevice"
        End If
        Call D3DKMTSetProcessSchedulingPriorityClass(GetCurrentProcess(), D3DKMT_SCHEDULINGPRIORITYCLASS_REALTIME)
        Set pDXGIDevice = pD3D11Device
        pDXGIDevice.SetGPUThreadPriority 7
        pDXGIDevice.SetMaximumFrameLatency 1
        If TypeOf pOutput Is IDXGIOutput5 Then
            Set pOutput5 = pOutput
            Dim aFormats(0 To 3) As DXGI_FORMAT
            aFormats(0) = DXGI_FORMAT_B8G8R8A8_UNORM
            aFormats(1) = DXGI_FORMAT_R8G8B8A8_UNORM
            aFormats(2) = DXGI_FORMAT_R10G10B10A2_UNORM
            aFormats(3) = DXGI_FORMAT_R16G16B16A16_FLOAT
            hResult = pOutput5.DuplicateOutput1(pD3D11Device, 0, UBound(aFormats) + 1, aFormats(0), .Duplication)
            If hResult < 0 Then
                Err.Raise hResult, "IDXGIOutput5.DuplicateOutput1"
            End If
        Else
            hResult = pOutput.DuplicateOutput(pD3D11Device, .Duplication)
            If hResult < 0 Then
                Err.Raise hResult, "IDXGIOutput1.DuplicateOutput"
            End If
        End If
        .Duplication.GetDesc uDuplDesc
        .InSystemMemory = (uDuplDesc.DesktopImageInSystemMemory <> 0)
        Debug.Assert uDuplDesc.ModeDesc.Format = DXGI_FORMAT_B8G8R8A8_UNORM
        With uTextureDesc
            .Width = uCtx.Width
            .Height = uCtx.Height
            .MipLevels = 1
            .ArraySize = 1
            .Format = uDuplDesc.ModeDesc.Format
            .SampleDesc.Count = 1
            .SampleDesc.Quality = 0
            .Usage = D3D11_USAGE_STAGING
            .BindFlags = 0
            .CPUAccessFlags = D3D11_CPU_ACCESS_READ
            .MiscFlags = 0
        End With
        Set .StageTexture = pD3D11Device.CreateTexture2D(uTextureDesc)
        hResult = .Context.Map(.StageTexture, 0, D3D11_MAP_READ, 0, uResource)
        If hResult < 0 Then
            Err.Raise hResult, "ID3D11DeviceContext.Map"
        End If
        .Pitch = uResource.RowPitch
        .Stride = uResource.RowPitch / IIf(uDuplDesc.ModeDesc.Format = DXGI_FORMAT_R16G16B16A16_FLOAT, 8, 4)
        .Context.Unmap .StageTexture, 0
    End With
    '--- success
    pvInitCapture = True
QH:
    Exit Function
EH:
    PrintError FUNC_NAME
End Function

Private Function pvCaptureScreen(uCtx As UcsDuplicationContext, oPicDesktop As StdPicture, oPicPointer As StdPicture, uCapture As UcsCaptureFrame) As Boolean
    Const FUNC_NAME    As String = "pvCaptureScreen"
    Const SIZE_OUTDUPL_MOVE_RECT As Long = 24
    Const SIZE_RECT    As Long = 16
    Const BLACK_COLOR  As Long = &HFF000000
    Dim hResult        As Long
    Dim lIdx            As Long
    Dim uResource      As D3D11_MAPPED_SUBRESOURCE
    Dim hMemDC          As Long
    Dim hDib            As Long
    Dim uMapRect        As DXGI_MAPPED_RECT
    Dim lSize          As Long
    Dim dblTimerEx      As Double
    Dim lX              As Long
    Dim lY              As Long
    Dim pTex            As ID3D11Texture2D
    Dim uFrameInfo      As DXGI_OUTDUPL_FRAME_INFO
    Dim aMask(0 To 7)  As Byte
    Dim uPointerInfo    As DXGI_OUTDUPL_POINTER_SHAPE_INFO

    On Error GoTo EH
    dblTimerEx = TimerEx
    With uCtx
        If .Duplication Is Nothing Then
            GoTo QH
        End If
        If Not .DesktopResource Is Nothing Then
            .Duplication.ReleaseFrame
            Set .DesktopResource = Nothing
        End If
        hResult = .Duplication.AcquireNextFrame(1, uFrameInfo, .DesktopResource)
        If hResult = DXGI_ERROR_WAIT_TIMEOUT Then
            '--- success
            pvCaptureScreen = True
            GoTo QH
        End If
        If hResult < 0 Then
            GoTo QH
        End If
        If uFrameInfo.LastPresentTime.LowPart <> 0 Or uFrameInfo.LastPresentTime.HighPart <> 0 Then
            Set pTex = .StageTexture
        End If
        '--- init mem dc
        hMemDC = CreateCompatibleDC(0)
        If hMemDC = 0 Then
            GoTo QH
        End If
        '--- capture frame
        hResult = .Duplication.GetFrameMoveRects((UBound(uCapture.MoveRects) + 1) * SIZE_OUTDUPL_MOVE_RECT, uCapture.MoveRects(0), lSize)
        If hResult = DXGI_ERROR_MORE_DATA Then
            ReDim uCapture.MoveRects(0 To lSize \ SIZE_OUTDUPL_MOVE_RECT - 1) As DXGI_OUTDUPL_MOVE_RECT
            hResult = .Duplication.GetFrameMoveRects((UBound(uCapture.MoveRects) + 1) * SIZE_OUTDUPL_MOVE_RECT, uCapture.MoveRects(0), lSize)
        End If
        If hResult < 0 Then
            GoTo QH
        End If
        uCapture.NumMoveRects = lSize / SIZE_OUTDUPL_MOVE_RECT
        hResult = .Duplication.GetFrameDirtyRects((UBound(uCapture.DirtyRects) + 1) * SIZE_RECT, uCapture.DirtyRects(0), lSize)
        If hResult = DXGI_ERROR_MORE_DATA Then
            ReDim uCapture.DirtyRects(0 To lSize \ SIZE_RECT - 1) As D3D11_RECT
            hResult = .Duplication.GetFrameDirtyRects((UBound(uCapture.DirtyRects) + 1) * SIZE_RECT, uCapture.DirtyRects(0), lSize)
        End If
        If hResult < 0 Then
            GoTo QH
        End If
        uCapture.NumDirtyRects = lSize / SIZE_RECT
        If uFrameInfo.PointerShapeBufferSize > 0 Then
            hResult = .Duplication.GetFramePointerShape((UBound(uCapture.PointerShape) + 1), uCapture.PointerShape(0), uCapture.PointerSize, uPointerInfo)
            If hResult = DXGI_ERROR_MORE_DATA Then
                ReDim uCapture.PointerShape(0 To uCapture.PointerSize - 1) As Byte
                hResult = .Duplication.GetFramePointerShape((UBound(uCapture.PointerShape) + 1), uCapture.PointerShape(0), uCapture.PointerSize, uPointerInfo)
            End If
            If hResult < 0 Then
                GoTo QH
            End If
            uCapture.PointerHotspot = uPointerInfo.HotSpot
        End If
        If uFrameInfo.LastMouseUpdateTime.LowPart <> 0 Or uFrameInfo.LastMouseUpdateTime.HighPart <> 0 Then
            uCapture.PointerVisible = (uFrameInfo.PointerPosition.Visible <> 0)
            uCapture.PointerPlacement.Left = uFrameInfo.PointerPosition.Position.X
            uCapture.PointerPlacement.Top = uFrameInfo.PointerPosition.Position.Y
        End If
        '--- copy desktop
        If .DesktopPicture Is Nothing Then
            If Not pvCreateDib(hMemDC, .Width, .Height, hDib, .DesktopBitsPtr) Then
                GoTo QH
            End If
            If Not pvCreateStdPicture(hDib, .DesktopPicture) Then
                GoTo QH
            End If
            hDib = 0
            Set oPicDesktop = .DesktopPicture
        End If
        If .InSystemMemory Then
            .Duplication.MapDesktopSurface uMapRect
            For lIdx = 0 To .Height - 1
                Call CopyMemory(ByVal .DesktopBitsPtr + lIdx * .Width * 4, ByVal uMapRect.pBitsPtr + lIdx * uMapRect.Pitch, .Width * 4)
            Next
            .Duplication.UnMapDesktopSurface
        ElseIf Not pTex Is Nothing Then
            .Context.CopyResource pTex, .DesktopResource
            hResult = .Context.Map(pTex, 0, D3D11_MAP_READ, 0, uResource)
            If hResult < 0 Then
                Err.Raise hResult, "ID3D11DeviceContext.Map"
            End If
            #If SHOW_DELTA Then
                For lIdx = 0 To .Height - 1
                    Call CopyMemory(ByVal .DesktopBitsPtr + lIdx * .Width * 4, ByVal uResource.pDataPtr + lIdx * uResource.RowPitch, .Width * 4)
                Next
                Const BORDER_COLOR  As Long = &HFFFF0000
                For lIdx = 0 To uCapture.NumDirty - 1
                    For lX = uCapture.DirtyRects(lIdx).Left To uCapture.DirtyRects(lIdx).Right - 1
                        Call CopyMemory(ByVal .DesktopBitsPtr + (uCapture.DirtyRects(lIdx).Top * .Width + lX) * 4, BORDER_COLOR, 4)
                        Call CopyMemory(ByVal .DesktopBitsPtr + ((uCapture.DirtyRects(lIdx).Bottom - 1) * .Width + lX) * 4, BORDER_COLOR, 4)
                    Next
                    For lY = uCapture.DirtyRects(lIdx).Top To uCapture.DirtyRects(lIdx).Bottom - 1
                        Call CopyMemory(ByVal .DesktopBitsPtr + (lY * .Width + uCapture.DirtyRects(lIdx).Left) * 4, BORDER_COLOR, 4)
                        Call CopyMemory(ByVal .DesktopBitsPtr + (lY * .Width + uCapture.DirtyRects(lIdx).Right - 1) * 4, BORDER_COLOR, 4)
                    Next
                Next
            #Else
                For lIdx = 0 To uCapture.NumDirtyRects - 1
                    lX = uCapture.DirtyRects(lIdx).Left
                    For lY = uCapture.DirtyRects(lIdx).Top To uCapture.DirtyRects(lIdx).Bottom - 1
                        Call CopyMemory(ByVal .DesktopBitsPtr + (lY * .Width + lX) * 4, ByVal uResource.pDataPtr + lY * uResource.RowPitch + lX * 4, (uCapture.DirtyRects(lIdx).Right - lX) * 4)
                    Next
                Next
            #End If
            .Context.Unmap pTex, 0
            uResource.pDataPtr = 0
        End If
        '--- copy pointer
        If uFrameInfo.PointerShapeBufferSize > 0 Then
            If uPointerInfo.Type <> DXGI_OUTDUPL_POINTER_SHAPE_TYPE_COLOR Then
                uPointerInfo.Height = uPointerInfo.Height \ 2
            End If
            If Not pvCreateDib(hMemDC, uPointerInfo.Width, uPointerInfo.Height, hDib, .PointerBitsPtr) Then
                GoTo QH
            End If
            If Not pvCreateStdPicture(hDib, .PointerPicture) Then
                GoTo QH
            End If
            hDib = 0
            Set oPicPointer = .PointerPicture
            Select Case uPointerInfo.Type
            Case DXGI_OUTDUPL_POINTER_SHAPE_TYPE_COLOR
                For lY = 0 To uPointerInfo.Height - 1
                    Call CopyMemory(ByVal .PointerBitsPtr + lY * uPointerInfo.Width * 4, uCapture.PointerShape(lY * uPointerInfo.Pitch), uPointerInfo.Width * 4)
                Next
            Case DXGI_OUTDUPL_POINTER_SHAPE_TYPE_MONOCHROME
                For lIdx = 0 To 7
                    aMask(lIdx) = &H80 \ 2 ^ (lIdx Mod 8)
                Next
                '--- collect XOR mask only (skip AND)
                lIdx = uPointerInfo.Pitch * uPointerInfo.Height
                For lY = 0 To uPointerInfo.Height - 1
                    For lX = 0 To uPointerInfo.Width - 1
                        If (uCapture.PointerShape(lIdx + lY * uPointerInfo.Pitch + lX \ 8) And aMask(lX Mod 8)) <> 0 Then
                            Call CopyMemory(ByVal .PointerBitsPtr + (lY * uPointerInfo.Width + lX) * 4, BLACK_COLOR, 4)
                        End If
                    Next
                Next
            Case Else
                Debug.Print ".PointerInfo.Type=" & Hex(uPointerInfo.Type)
            End Select
            uCapture.PointerPlacement.Right = uPointerInfo.Width
            uCapture.PointerPlacement.Bottom = uPointerInfo.Height
        End If
    End With
    '--- success
    pvCaptureScreen = True
QH:
    If hDib <> 0 Then
        Call DeleteObject(hDib)
        hDib = 0
    End If
    If hMemDC <> 0 Then
        Call DeleteDC(hMemDC)
        hMemDC = 0
    End If
    If uResource.pDataPtr <> 0 Then
        uCtx.Context.Unmap pTex, 0
    End If
    If Not pTex Is Nothing Then
        Debug.Print "Elapsed=" & Format(TimerEx - dblTimerEx, "0.000")
    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 Function pvCreateStdPicture(hDib As Long, oPic As StdPicture) As Boolean
    Const FUNC_NAME    As String = "pvCreateStdPicture"
    Dim uDesc          As PICTDESC
    Dim aGUID(0 To 3)  As Long
   
    On Error GoTo EH
    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
    '--- success
    pvCreateStdPicture = True
QH:
    Exit Function
EH:
    PrintError FUNC_NAME
End Function

Public Property Get TimerEx() As Double
    Dim cFreq          As Currency
    Dim cValue          As Currency
   
    Call QueryPerformanceFrequency(cFreq)
    Call QueryPerformanceCounter(cValue)
    TimerEx = cValue / cFreq
End Property

'=========================================================================
' Control events
'=========================================================================

Private Sub Form_Load()
    Dim vElem          As Variant
   
    With m_uFrame
        ReDim .MoveRects(0 To 0) As DXGI_OUTDUPL_MOVE_RECT
        ReDim .DirtyRects(0 To 0) As D3D11_RECT
        ReDim .PointerShape(0 To 0) As Byte
    End With
    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
        If ScaleHeight - dblTop > 0 Then
            imgDesktop.Move 0, dblTop, ScaleWidth, ScaleHeight - dblTop
        End If
    End If
End Sub

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

Private Sub imgDesktop_Click()
    Timer1.Enabled = Not Timer1.Enabled
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 1461 articles
Browse latest View live


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