Hide IDEOwner Class Window when loading IDE

December 20, 2021, 9:38 am

≫ Next: NaN and Inf numbers for IEEE Singles in VB6

≪ Previous: [VB6] WinXP compatible PBKDF2

$

0

0

I'm not sure if this just happens when running SDI (which is the only way I run) for the VB6 IDE, or if it happens for everyone.

But, when I load the IDE, ever since about the beginning of Windows 10, I get this little window on the center of my screen, If I minimize and then re-normalize the IDE, it goes away. But that's annoying. For years, I've just been ignoring it, but I finally decided to do something about it.

This little add-in attempts to hide it when the IDE loads. Its class is named "IDEOwner", and it seems to be the only window that's part of the IDE with that class name. So, that's how I found it (programmatically).

Here's code in the add-ins DSR module:

Code:

---


Option Explicit
'
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
'

Private Sub AddinInstance_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, custom() As Variant)
    Dim hWnds() As Long
    hWnds = hWndOfAllTopLevelWindows ' Only ones belonging to our PID.
    '
    ' Find the IDEOwner Class
    Dim i As Long
    Dim hWndIdeOwner As Long
    For i = LBound(hWnds) To UBound(hWnds)
        If WindowClass(hWnds(i)) = "IDEOwner" Then
            hWndIdeOwner = hWnds(i)
            Erase hWnds
            Exit For
        End If
    Next
    '
    ' Now hide it.
    Const SW_HIDE As Long = 0&
    If hWndIdeOwner Then
        ShowWindow hWndIdeOwner, SW_HIDE
    End If
End Sub

Private Function WindowClass(hWndOfInterest As Long) As String
    WindowClass = String$(1024&, 0&)
    WindowClass = Left$(WindowClass, GetClassName(hWndOfInterest, WindowClass, 1024&))
End Function




---

And here's some code that needed to be in a BAS module (so AddressOf could be used):

Code:

---


Option Explicit
'
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
'
Dim hWnds() As Long
Dim hWndCount As Long
'

Public Function hWndOfAllTopLevelWindows() As Long()
    hWndCount = 0&
    ReDim hWnds(99&)
    EnumWindows AddressOf EnumWindowsCallBack, &H0& ' Doesn't return until done.
    If hWndCount > 0& Then
        ReDim Preserve hWnds(hWndCount - 1&)
    Else
        ReDim hWnds(0&)
    End If
    hWndOfAllTopLevelWindows = hWnds
    Erase hWnds
End Function

Private Function EnumWindowsCallBack(ByVal hWnd As Long, ByVal lpData As Long) As Long
    EnumWindowsCallBack = 1&
    If ProcessID(hWnd) = GetCurrentProcessId Then
        hWndCount = hWndCount + 1&
        If UBound(hWnds) < hWndCount Then ReDim Preserve hWnds(UBound(hWnds) + 100&)
        hWnds(hWndCount) = hWnd
    End If
End Function

Private Function ProcessID(hWndOfInterest As Long) As Long
    Call GetWindowThreadProcessId(hWndOfInterest, ProcessID)
End Function



---

And the whole project is attached (minus the actual add-in's DLL).

I also included some little DLLReg and DLLUnreg scripts for registering/unregistering this in case you needed to. However, just compiling it will register it, so long as you save your DLL in a reasonable place. I save my add-in DLLs in the following folder: C:\Program Files (x86)\Microsoft Visual Studio\VB6_Addins

Enjoy.

Attached Files

• HideIdeOwnerWnd.zip (3.9 KB)

---

NaN and Inf numbers for IEEE Singles in VB6

December 20, 2021, 10:25 am

≫ Next: Enum windows without any widely scoped variables

≪ Previous: Hide IDEOwner Class Window when loading IDE

$

0

0

I needed this the other day, so I coded it up (IEEE Single Precision):

Code:

---


Option Explicit
'
Public Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, ByRef Dest As Any) As Long ' Always ignore the returned value, it's useless.
'

Public Function fNaN() As Single
    ' Math (add, subtract, multiply, divide) can be done on these, but nothing changes.
    ' They can NOT be used in "if fNaN = fNaN Then", or an overflow will result.  Use fIsNaN().
    GetMem4 &H7FFFFFFF, fNaN
End Function

Public Function fInf() As Single
    GetMem4 &H7F800000, fInf
End Function

Public Function fIsNaN(ByVal f As Single) As Boolean
    fIsNaN = fIsNanOrInf(f) And Not fIsInf(f)
End Function

Public Function fIsInf(f As Single) As Boolean
    Dim i As Long
    GetMem4 f, i
    i = i And &H7FFFFFFF  ' Make sure it's positive.
    fIsInf = i = &H7F800000
End Function

Public Function fIsNeg(f As Single) As Boolean
    ' This works even on fNaN and fInf.
    Dim i As Long
    GetMem4 f, i
    fIsNeg = (i And &H80000000) <> 0&
End Function

Public Function fIsNanOrInf(f As Single) As Boolean
    Dim i As Long
    GetMem4 f, i
    i = i And &H7F800000    ' Strip off sign bit and the entire fraction part.
    fIsNanOrInf = i = &H7F800000
End Function

Public Function PtrAdd(ByVal Ptr As Long, ByVal iOffset As Long) As Long
    ' For adding (or subtracting) a small number from a pointer.
    ' Use PtrAddEx for adding (or subtracting) large numbers from a pointer.
    PtrAdd = (Ptr Xor &H80000000) + iOffset Xor &H80000000
End Function




---

I had already done it for IEEE Doubles, found here. That thread also has a bit more context you may enjoy reading.

Just FYI, I often use the "f" as a Hungarian prefix to denote Single precision (I think "float").

Enjoy,
Elroy

Enum windows without any widely scoped variables

December 23, 2021, 10:29 pm

≫ Next: VB6 R-Tree Demo for large Game-Maps

≪ Previous: NaN and Inf numbers for IEEE Singles in VB6

$

0

0

This isn't anything terribly special, but it is something I've been wanting to do for some time.

It's just a top-level window enumeration, but it's accomplished without any global nor module level variables. I've done similar things with other API enumerations (using the lpData argument), but I've just never done it for the EnumWindows API. I particularly like it when all variables are kept local (or just passed to sub-procedures (or, in this case, callbacks)).

So, here it is (best in a BAS module):

Code:

---


Option Explicit
'
Private Declare Sub SafeArrayAllocDescriptor Lib "oleaut32" (ByVal cDims As Long, ByRef psaInOut As Long)
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function vbaObjSetAddref Lib "msvbvm60" Alias "__vbaObjSetAddref" (ByRef dstObject As Any, ByRef srcObjPtr As Any) As Long
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (a() As Any) As Long
'

Public Function hWndOfAllTopLevelWindows(Optional iSpecificProcessId As Long = -1&) As Long()
    ' Returns a 0 to -1 array if none found, but it ALWAYS returns a dimensioned array (so that LBound and UBound can be used).
    ' The caller should use GetCurrentProcessId if you wish to get windows for just this process.
    '
    Dim hWndsColl As New Collection
    ' Gather ALL of them.
    EnumWindows AddressOf EnumWindowsCallBack, ObjPtr(hWndsColl) ' Doesn't return until done.
    ' See if we only want a specific PID, and delete non-matches if so.
    If iSpecificProcessId <> -1& Then
        Dim i As Long
        For i = hWndsColl.Count To 1& Step -1&
            If ProcessId(CLng(hWndsColl.Item(i))) <> iSpecificProcessId Then hWndsColl.Remove i
        Next
    End If
    ' Transfer into our return array.
    If hWndsColl.Count Then
        hWndOfAllHelper hWndOfAllTopLevelWindows, hWndsColl
    Else
        SafeArrayAllocDescriptor 1&, ByVal ArrPtr(hWndOfAllTopLevelWindows) ' Makes a 0 to -1 array.
    End If
End Function

Private Sub hWndOfAllHelper(hArray() As Long, coll As Collection)
    ReDim hArray(coll.Count - 1&)
    Dim v As Variant
    Dim iPtr As Long
    For Each v In coll
        hArray(iPtr) = v
        iPtr = iPtr + 1&
    Next
End Sub

Private Function EnumWindowsCallBack(ByVal hWnd As Long, ByVal lpData As Long) As Long
    Dim coll As Collection  ' Will de-reference when we fall out of scope.
    vbaObjSetAddref coll, ByVal lpData
    coll.Add hWnd
    EnumWindowsCallBack = 1&
End Function

Public Function ProcessId(hWndOfInterest As Long) As Long
    Call GetWindowThreadProcessId(hWndOfInterest, ProcessId)
End Function



---

And here's some test code for a Form1:

Code:

---


Option Explicit
'
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long ' Returns OUR PID.
Private Declare Function GetWindowTextLengthW Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowTextW Lib "user32" (ByVal hWnd As Long, ByVal lpString As Long, ByVal cch As Long) As Long
'

Private Sub Form_Load()
    Dim ia() As Long
    ia = hWndOfAllTopLevelWindows(GetCurrentProcessId)  ' Limit it to just our windows.

    Debug.Print "Count: "; UBound(ia) - LBound(ia) + 1&

    Dim i As Long
    For i = LBound(ia) To UBound(ia)
        Debug.Print ia(i), ProcessId(ia(i)), WindowText(ia(i))
    Next


    Unload Me
End Sub

Public Function WindowText(hWndOfInterest As Long) As String
    WindowText = Space$(GetWindowTextLengthW(hWndOfInterest))
    WindowText = Left$(WindowText, GetWindowTextW(hWndOfInterest, StrPtr(WindowText), Len(WindowText) + 1&))
End Function




---

You can take out the GetCurrentProcessId (and let it default to -1) to get ALL top level windows, but it'll probably overflow the Immediate window.

Enjoy,
Elroy

VB6 R-Tree Demo for large Game-Maps

January 8, 2022, 9:17 am

≫ Next: Which variable type for math on duration value ?

≪ Previous: Enum windows without any widely scoped variables

$

0

0

In larger 2D (or 2.5D) Games, there's often the question of efficient Map-Handling...
Not only with regards to Map-creation or -definition, but also with regards to efficient re-rendering after the View-Rectangle was shifted.

This Demo addresses these questions, by placing *all* the resources in a little SQLite-DB in the App-Path.
(it contains Routines, which can import Tile- and Map-Placment-Infos into this DB efficiently).

It also contains Code, which demonstrates an efficient Selection (via SQL, in about 1msec) of:
- all Tile-Types which are fully contained in the current View-Window, as well as
- all Tile-Types which are only partially contained (overlap) with the current View-Window

The reason for the good query-performance (even if your world is made up, out of Millions of different Tiles),
is the SQLite RTree-Module (demonstrated in Class cTilePlacments).

Beginners should not be discouraged, the Code-Volume in each of the 4 Modules is (on average) only 50 Lines.
It is also well-commented, and to get a first impression how everything works together, perhaps start with stepping through with the <F8>-Key.

Here is, what it looks like:


At the Top-Left-Corner there's a little PicBox, which shows the "global World" in its entirety.
Within that PicBox is a little red-bordered Shape-Rectangle, which can be moved with the Mouse...
And when moved, the "View-Window" (in our case the entire Form) will "follow along", rendering the found Tiles in that View...

Ok, here's the Source-Code: RTreeMapDemo.zip

Have fun,

Olaf

Attached Files

• RTreeMapDemo.zip (28.6 KB)

Which variable type for math on duration value ?

January 10, 2022, 10:55 pm

≫ Next: [VB6, Win7+] Undocumented ListView Feature: Multiselect in first column like Explorer

≪ Previous: VB6 R-Tree Demo for large Game-Maps

$

0

0

Hi,

On Jingle Palette, I'm adding the duration of each jingles.

I get each duration from BASS Plugin :

Code:

---

Dim cHandle As String
Dim JSec As Variant
cHandle = BASS_StreamCreateFile(BASSFALSE, tpath, 0, 0, 0)
JSec = BASS_ChannelBytes2Seconds(cHandle, BASS_StreamGetLength(cHandle))

---

MsgBox JSec displays the jingle duration with 5 decimals with comma. For example 17,54832

If before MsgBox, I do some math functions, to get a friendly value :
JSec = Round(JSec + 0.05, 2)
JSec = Fix(JSec * 10) / 10
JSec = FormatNumber(JSec, 1)

I get 17,6

I store the 5 decimals value in palette.ini file (where are stored palettes and jingles infos like loop mode etc etc). For example, the first jingle duration of a palette :
Duration_0=17,54832

Then, Jingle Palette reads the ini file on loading a palette (at launch, or if I change another palette)

Code:

---

Dim DurationDisp As Variant
DurationDisp = PalSet.Entry("Duration_" & Index, , Section) 'Reading from palette.ini file
DurationDisp = Round(DurationDisp + 0.05, 2)
DurationDisp = Fix(DurationDisp * 10) / 10
DurationDisp = FormatNumber(DurationDisp, 1)

---

I get a mismatch error since the first math operation ( DurationDisp = Round(DurationDisp + 0.05, 2) ).

I replace ini file reading by a fixed value :

Code:

---

DurationDisp = "17,54832"

---

I get no error and the math function are done.

Same thinkg with:

Code:

---

DurationDisp = 17.54832

---

I tried this :

Code:

---

DurationDisp = CStr(PalSet.Entry("Duration_" & Index, , Section))

---

and this :

Code:

---

DurationDisp = CDec(PalSet.Entry("Duration_" & Index, , Section))

---

But I still get error :(

I tried to store duration with point instead of comma (with Replace function), but nithing better.

I don't know where to search :(

Some ideas ?

Thanks ! :)

[VB6, Win7+] Undocumented ListView Feature: Multiselect in first column like Explorer

January 13, 2022, 9:33 am

≫ Next: [VB6, Win7+] Undocumented ListView Feature: Multiselect in columns like Explorer

≪ Previous: Which variable type for math on duration value ?

$

0

0

Undocumented ListView Features : Part 5 - Explorer-style selection
See Also: Part 1 - Footer Items | Part 2 - Subsetted Groups | Part 3 - Groups With Virtual Mode | Part 4 - Column Backcolor

In Windows Explorer, when you're in Details View, you can start a selection marquee in the first column. However in a ListView, even set to Explorer Style, dragging anywhere in the column starts a dragdrop operation (or does nothing if DD is disabled). It's possible to enable the multiselection marquee when dragging in the first column whitespace like Explorer using the undocumented IListView interface's SetSelectionFlags call. There's no LVM_ message, so the only downside is a TLB is required.

Requirements
Windows 7 or newer - While Vista does have an IListView interface available under a different GUID, this call seems not to work.
oleexp.tlb v4.42 or higher (Recommended) or the deprecated lvundoc.tlb
oleexp Add-on mIID.bas (included in oleexp download) - If you want to use the old lvundoc.tlb, you can supply your own definition of IID_IListView.


First of all, obviously this is only applicable to Details View with Multiselect enabled, and this only applies to a ListView with Explorer Style enabled,

Code:

---

SetWindowTheme hWnd, StrPtr("explorer"), 0&

---

Once your ListView is set up, here's what you need:

Code:

---

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long


Private Sub LVSetExplSel(hwndLV As Long, bOn As Boolean)
Dim pILV As oleexp.IListView

SendMessage hwndLV, LVM_QUERYINTERFACE, VarPtr(IID_IListView), pILV
If (pILV Is Nothing) = False Then
    pILV.SetSelectionFlags 1&, iif(bOn, 1&, 0&)
Else
    Debug.Print "LVSetExplSel::Failed to get IListView"
End If

End Sub

---

It can be toggled on and off, use bOn = True to turn it on.

Attached Images

 

[VB6, Win7+] Undocumented ListView Feature: Multiselect in columns like Explorer

January 13, 2022, 9:33 am

≫ Next: [VB6] Using IShellWindows to register for SHOpenFolderAndSelectItems

≪ Previous: [VB6, Win7+] Undocumented ListView Feature: Multiselect in first column like Explorer

$

0

0

Undocumented ListView Features : Part 5 - Explorer-style selection
See Also: Part 1 - Footer Items | Part 2 - Subsetted Groups | Part 3 - Groups With Virtual Mode | Part 4 - Column Backcolor

In Windows Explorer, when you're in Details View, you can start a selection marquee in the white space of columns. However in a ListView, even set to Explorer Style, dragging anywhere in the column starts a dragdrop operation (or does nothing if DD is disabled). It's possible to enable the multiselection marquee when dragging in the column whitespace like Explorer using the undocumented IListView interface's SetSelectionFlags call. There's no LVM_ message, so the only downside is a TLB is required.

Requirements
Windows 7 or newer - While Vista does have an IListView interface available under a different GUID, this call seems not to work.
oleexp.tlb v4.42 or higher (Recommended) or the deprecated lvundoc.tlb
oleexp Add-on mIID.bas (included in oleexp download) - If you want to use the old lvundoc.tlb, you can supply your own definition of IID_IListView.


First of all, obviously this is only applicable to Details View with Multiselect enabled, and this only applies to a ListView with Explorer Style enabled,

Code:

---

SetWindowTheme hWnd, StrPtr("explorer"), 0&

---

Once your ListView is set up, here's what you need:

Code:

---

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const LVM_FIRST = &H1000
Private Const LVM_QUERYINTERFACE = (LVM_FIRST + 189)      'UNDOCUMENTED


Private Sub LVSetExplSel(hwndLV As Long, bOn As Boolean)
Dim pILV As oleexp.IListView

SendMessage hwndLV, LVM_QUERYINTERFACE, VarPtr(IID_IListView), pILV
If (pILV Is Nothing) = False Then
    pILV.SetSelectionFlags 1&, iif(bOn, 1&, 0&)
Else
    Debug.Print "LVSetExplSel::Failed to get IListView"
End If

End Sub

---

It can be toggled on and off, use bOn = True to turn it on.

If FullRowSelect is disabled, you can start a selection marquee from other columns regardless of the text. If FullRowSelect is enabled, the behavior of the first column applies to the others as well-- dragging from the text starts a dragdrop, dragging from the whitespace starts a multiselect marquee.

Attached Images

 

[VB6] Using IShellWindows to register for SHOpenFolderAndSelectItems

January 18, 2022, 11:57 pm

≫ Next: Homegrown Popup Menus with Tooltips

≪ Previous: [VB6, Win7+] Undocumented ListView Feature: Multiselect in columns like Explorer

$

0

0

Shell Window Registration

People who've made Explorer replacements or other apps that display a window have found that they can, at best, get the folder passed to them when someone uses 'Show in folder'/'Show in Explorer' in apps like Firefox, Chrome, and torrent clients. However, if you register everything properly, any app calling SHOpenFolderAndSelectItems will be able to pass the names of selected files to a folder you've registered as displaying.

Note that for it to start your app if it's not running with the path in question registered, it will have to be the default that opens when you pass a folder to ShellExecuteEx (i.e. registered as an Explorer replacement on the system).

Some time between Windows XP and Windows 10 the API changed. I've completed this demo for Windows 10, and whatever versions use IShellView to select the items. Windows XP uses IShellFolderViewDual instead. A little more work needs to be done there, since the pidl is passed in a variant. I've gotten it almost there though, the SelectItem function will output the VARENUM type of the variant. From there it just has to be converted to a long. I'll do that in a later version as I'll have to set up virtual machines.

Requirements
oleexp.tlb v4.8 (Released with this demo on 2022 Jan 19)
oleexpimp.tlb v2.07+ (oleexp 4.8 now comes with v2.1 but a few people grabbed it before I changed it-- you'll need 2.1 for future projects related to this, but not this)
oleexp Add-on mIID.bas (Included in the oleexp download, be sure to use the one from 4.8)

---

The question of how to do this has been asked many times in various forums for various languages, but apart from alluding to the need to use IShellWindows.RegisterPending, nobody definitely answered.

Special thanks to The_trick for identifying the problem with MSDN's IShellWindows documentation... RegisterPending absolutely does not accept a VT_VARIANT|VT_BYREF variant, but will accept any number of types of variants that can be converted to a pidl. This demo uses a simple BSTR (VB's String type), and The_trick notes it also accepts a CSIDLs, IPersistIDList, IPersistFolder2, IStream, and Byte Arrays (perhaps containing a full ITEMIDLIST structure rather than a pointer to one?). More work is needed to identify the best way to work with this.

The key is using both RegisterPending and Register, since RegisterPending accepts a path but not an object implementing all the required interfaces, and Register takes the object but not a path (and it never tries looking anything up). It uses APIs to convert the ThreadID to an hWnd to associate them-- you'll find that the cookie RegisterPending returns will be the same as the one RegisterReturns, even if you don't use the same variable like my code; this shows that, unlike MSDN indicates, this calls are two parts of the same whole.

In a full app, you'd call RegisterPending, create the file display, then finalize with Register.

Code:

---

    Set pSW = New ShellWindows
    Set pDisp = ucSW1.object
    pSW.RegisterPending App.ThreadID, Text1.Text, VarPtr(vre), SWC_BROWSER, lCookie
    pSW.Register pDisp, Form1.hWnd, SWC_BROWSER, lCookie

---

In the future I plan on releasing a more complete implementation of these various folder interfaces that work with my Shell Browser control, to create a full replacement for Explorer.

As a bonus, the UserControl has full prototypes for several additional interfaces that weren't used.

Notes

-RegisterPending and Register are linked... two parts of the same whole both needed for a shell window. The way it wprks, your app can register multiple locations with RegisterPending, but each one must have a unique hWnd associated with it... this is because when Register is called to finalize it, it looks up the thread with GetWindowThreadProcessId to complete the information.

-If you do register multiple windows, you must complete them one at a time (RegisterPending, load, Register)... because each Register call will take the most recent matching thread ID because it steps backwards through the structures that have been added.

-Whenever you're closing out a folder, call IShellWindows.Revoke with the cookie (keep track of them per-window). Register will return the same cookie RegisterPending did; if these get mismatched, it would be because you called RegisterPending multiple times before Register, and represent a problem.

Attached Images

 

Attached Files

• RegShellWindowDemo.zip (5.7 KB)

---

Homegrown Popup Menus with Tooltips

January 22, 2022, 9:19 am

≫ Next: VB6 DPI-awareness via RC6/RC6Widgets (and Device-Independent-Pixels)

≪ Previous: [VB6] Using IShellWindows to register for SHOpenFolderAndSelectItems

$

0

0

The main downside to my homegrown approach is that it won't work on modal forms. However, I try to not do that, so this serves my needs well.

The main reason I did this is that I wanted popup menus with tooltips, which I accomplished.

Screenshot:



Everything you need to use it is in the code in Form1. The sample project is attached, but here's the Form1 code:

Code:

---


Option Explicit

Private Sub Form_Load()
    AddPopupItem "TestMenu", "Popup Item 1", "This is a tooltip for the popup item #1"
    AddPopupItem "TestMenu", "Popup Item 2", "This is a tooltip for the popup item #2"
    AddPopupItem "TestMenu", "-"
    AddPopupItem "TestMenu", "Popup Item 3", "This is a tooltip for the popup item #3"
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then ShowPopupMenu Me, "TestMenu"
End Sub

Public Sub PopupClicked(sPopupMenu As String, sPopupItem As String)
    Debug.Print "Clicked: "; sPopupMenu; " "; sPopupItem
End Sub



---

You just add all your popup menu items beforehand, and then call the popup when you need it. As an FYI, you should add all your popup items beforehand (maybe in a Sub Main) and then they're there for the life of the project. However, if you put them into a Form_Load of a form that's repeatedly loaded, that's ok too, as duplicates are checked and disallowed.

Be sure to add the PopupClicked to your calling form (with the arguments shown) so you can get the info about the popup item clicked.

There are just two procedures you use in the mod_Gen_PopupSupport module (AddPopupItem & ShowPopupMenu) and that's it. The rest is just support.

Also, there is a bit of subclassing, but it's only done when the popup menu is showing. And, since it won't work on modal forms, it should be quite safe for the VB6 IDE, even if you click the Stop button. (The only place it might "get" you is if you're tracing through the popup menu code and click the IDE's Stop button while you're doing that. Tracing through your own code is fine though.)

Attached Images

 

Attached Files

• PopupMenuRollYourOwn.zip (8.2 KB)

VB6 DPI-awareness via RC6/RC6Widgets (and Device-Independent-Pixels)

January 22, 2022, 5:07 pm

≫ Next: MSHFlexGrid and RowSel bug?

≪ Previous: Homegrown Popup Menus with Tooltips

$

0

0

Just some Drop-In-Code (about 140 Code-Lines) for a normal VB6-Form,
producing the following output:



For those not yet familiar with the RC5/RC6 Widget-concept, here is a Tutorial-Link:
https://www.vbforums.com/showthread....dgets-Tutorial

Ok, when we look at the above ScreenShot, we see a simple ToolBar, a StatusBar -
and in-between these two "Stripes" - a Chart-Area.

The placements (and sizes) of these 3 "Form-covering-Widgets" are given in DIP (Device-Independent-Pixels).
The same is true for all the Placements and Sizes of the other Child-Widgets within these 3 "Main-Widgets".

Not working "with Twips" - but instead with DIP (don't interchange that with DPI),
is "how it works everywhere else" (in modern Browsers, as well as in modern Graphics- and UI-Frameworks).

And what it basically means is, that:
If you work in "Standard-Resolution" of 96DPI (aka 100% Monitor-Zoom),
then "a single DIP" covers "a single, real Pixel exactly" (in your BackBuffer-Surface).

Now, when the Monitor-Resultion is switched to e.g. 200% (192DPI Screen-Resolution),
then "a single DIP" covers "a 2x2 area of real Pixels on the underlying BackBuffer".

As for: "how can I tell my Graphics- or UI-lib to change the DIP-resolution" (to e.g. 200%)?
- if you work with Cairo-Surfaces and 'CCs' directly, you have to set the Zoom manually: CC.ScaleDrawings 2, 2
- if you work with RC6-Widgets, then everything is automatic, after you set: cWidgetRoot.Zoom = 2

To find out, what the current Monitor-ZoomFactor is, one can use: New_c.Displays(1).Zoom

E.g. on my Notebook, I have a 15"-4K-Display (covering 3840x2160 real Pixels).
This is a quite large area, on a relatively small Display, so my Monitor-Zoom is set to 250% (240DPI).

Here is the above seen (96DPI) Form-ScreenShot again (now in 240DPI), from the running App with enabled DPI-awareness -
(in the compiled Exe, automatically zoomed to 250% ... given as a normal Link, because of its size):
https://vbRichClient.com/Downloads/C...50_percent.png

So, if you compare the two ScreenShots, you see that there's no problem with DPI-awareness,
all the Controls are scaled properly - there is no "smaller Texts somewhere" or "some smaller Icons" -
and also not "smaller LineWidths" (even those scaled along properly, in the Chart-Area).

With "normal VB6-drawing" (no matter if Control-placements are in Twips) you have to jump through hoops,
to achieve a clean-scaled, DPI-aware result like that.

Ok, here the code for a virginal VB6-Form... (don't forget to include Project-Refs for RC6 and RC6-Widgets)

Code:

---

Option Explicit 'DPI-awareness and Device-Independent-Pixels (needs References to RC6 and RC6Widgets)

Private Declare Function GetClientRect& Lib "user32" (ByVal hWnd&, Rct As Any)

Const BarHeight = 31, BarColor = &HBCAFAF

Private WithEvents pnlCover As cWidgetForm 'the Form-covering Main-Panel-Host
Private ToolB As cwToolBar, WithEvents Chart As cwCanvas, StatB As cwStatusBar 'and the 3 Main-Widgets which are sitting directly on pnlCover

Private WithEvents tbiSave As cwToolBarItem, WithEvents tbiEdit As cwToolBarItem, WithEvents tbiMove As cwToolBarItem
Private txtCh0 As cwTextBox, txtCh1 As cwTextBox
Private sta1 As cwToolBarItem, sta2 As cwToolBarItem, WithEvents staZ As cwToolBarItem, WithEvents popZ As cwMenu

Private Sub Form_Load()
  Caption = "DPI-aware Chart-Demo (Resize Me...)"
  Cairo.SetDPIAwareness 'this will make the App DPI-aware (even without a manifest)

  'first we put a few Icon-Resources into the global ImageList (the Widgets will only need their StringKeys, to render them)
  Cairo.ImageList.AddIconFromResourceFile "icoSave", "shell32", 303
  Cairo.ImageList.AddIconFromResourceFile "icoEdit", "shell32", 242
  Cairo.ImageList.AddIconFromResourceFile "icoMove", "shell32", 22
  Cairo.ImageList.AddIconFromResourceFile "icoStar", "shell32", 44
  Cairo.ImageList.AddIconFromResourceFile "icoInfo", "shell32", 1001
  Cairo.ImageList.AddIconFromResourceFile "icoZoom", "shell32", 23
 
  'now we create a form-covering Panel (which acts as the host for 3 "Main-Containers", ToolBar, Chart-Area, StatusBar)
  Set pnlCover = Cairo.WidgetForms.CreateChild(hWnd)
      pnlCover.WidgetRoot.BackColor = &H888888
     
  'Ok, so let's create these 3 "Main-Container"-Widgets on their Parent-Panel, via pnlCover.Widgets.Add(...)
  Set ToolB = pnlCover.Widgets.Add(New cwToolBar, "ToolB", 0, 0, 1, BarHeight)
      ToolB.Widget.BackColor = BarColor 'change the default-backcolor to the Value of the Const-Def
  Set Chart = pnlCover.Widgets.Add("cwCanvas", "Chart") 'the Chart-Widget will fill the space between Tool- and StatusBar
  Set StatB = pnlCover.Widgets.Add(New cwStatusBar, "StatB", 0, 0, 1, BarHeight)
      StatB.Widget.BackColor = BarColor 'change the default-backcolor to the Value of the Const-Def

  'any Controls/Widgets live in a nested Hierarchy, so now we add specific ChildWidgets into the 3 Main-Containers themselves
  '... starting with a few Child-Items on the ToolBar
  Set tbiSave = ToolB.AddItem("tbiSave", "icoSave", "Save as *.png", , "Save the current ChartArea to a file")
                ToolB.AddItem "VSep1", , "-" 'vertical separator-lines require a unique Key, and a "-" as Caption-Text
  Set tbiEdit = ToolB.AddItem("tbiEdit", "icoEdit", "Allow Edit", , "Allow Chart-Text-Editing", , True)
  Set tbiMove = ToolB.AddItem("tbiMove", "icoMove", "Allow Move", , "Allow Chart-Text-Movements", , True)
                ToolB.AddItem "VSep2", , "-" 'vertical separator-lines require a unique Key, and a "-" as Caption-Text
 
  '... same here (adding two Child-Items, of type cwTextBox) to the Chart-Container via Chart.Widgets.Add(...)
  Set txtCh0 = Chart.Widgets.Add(New cwTextBox, "txtCh0", 0, 0, 320, 50)
      txtCh0.Text = "I'm a moveable Chart-Title..."
      txtCh0.Border = False: txtCh0.Widget.BackColor = -1 'no Border and no BackGroundColor for this Text
      txtCh0.Widget.ForeColor = vbBlue: txtCh0.Locked = True 'make this TextBox initially "un-editable"
      txtCh0.Widget.FontSize = 11: txtCh0.Widget.FontBold = True: txtCh0.Widget.FontItalic = True
      txtCh0.Widget.Tag = Array(0.03, 0.03)
  Set txtCh1 = Chart.Widgets.Add(New cwTextBox, "txtCh1", 0, 0, 160, 19)
      txtCh1.Text = "I'm a moveable Point-Marker..."
      txtCh1.Widget.FocusColor = txtCh1.Widget.BorderColor 'prevent the "light-blue-framing" of this TextBox when focused
      txtCh1.Widget.FontSize = 8: txtCh1.Locked = True 'make this TextBox initially "un-editable"
      txtCh1.Widget.Tag = Array(0.6, 0.7)
     
  '... and on the last Container (our StatusBar) we add a few "inset-styled" Child-Items as well
  Set sta1 = AddStatusItem("Info-Text: 1", "icoStar", 0, 100)
            AddStatusItem "-", "", 104, 4 'add a vertical separator
  Set sta2 = AddStatusItem("Info: 2", "icoInfo", 112, 80)
            AddStatusItem "-", "", 196, 4 'add another vertical separator
  Set staZ = AddStatusItem("Zoom: " & Format(New_c.Displays(1).Zoom, "0%"), "icoZoom", 666, 115)
      staZ.ArrowType = ddDropDown 'make staZ (in addition) - show a little, clickable Arrow to the right
  Set popZ = New cwMenu '<- a Menu-Widget, which is used within the staZ_ArrowClick Eventhandler
 
  '**** Ok, Control-initialization is finished...
 
  tbiMove.Checked = True 'ensure the "Checked"-Default-State of the ToolBar-"Allow Move"-Item
 
  'finally we set the pnl-Root-Zoom, according to what we find as the current Zoom of the Main-Display
  pnlCover.WidgetRoot.Zoom = New_c.Displays(1).Zoom 'setting the Zoom on the Root, will automatically scale the whole child-hierarchy currently "on it"
  'final Movement of our TopLevel-VB6-HostForm - relating to the Zoom-Fac we've just set on our covering-Panel
  With pnlCover.WidgetRoot: Me.Move Left * .Zoom, Top * .Zoom, Width * .Zoom, Height * .Zoom: End With
End Sub
 
Private Sub Form_Resize()
  Dim R&(0 To 3): GetClientRect hWnd, R(0) 'get the inner Pixel-dimensions of the VB-Form reliably (because TwipsPerPixel is broken)
  pnlCover.Move 0, 0, R(2), R(3) 'and move the covering Widget-HostPanel accordingly (will trigger the Event below)
End Sub

'in the Evt-Handler below, the incoming dx, dy are in "Device-Independent-Pixels" (which the Widget-Positioning-Logic relies on)
Private Sub pnlCover_ResizeWithDimensionsDIP(ByVal dx As Single, ByVal dy As Single)
  ToolB.Widget.Move 0, 0, dx, BarHeight
  Chart.Widget.Move 1, BarHeight, dx - 2, dy - 2 * BarHeight
  StatB.Widget.Move 0, dy - BarHeight, dx, BarHeight
  staZ.Widget.Move dx - 123, 3, 120 'after the StatB, adjust also the staZ-Widget, because it sits RightAligned on StatB
 
  UpdateTextWidgets
End Sub

Private Sub Chart_Paint(CC As cCairoContext, ByVal dx As Double, ByVal dy As Double)
  'the current chart-content is just a mock-up (using just 3 Points, derived relatively from the current dx/dy ChartArea-Extents)
  'in production-code, one should pass the 3 incoming Params along into several SubRoutines like: DrawCurve(...), DrawCandles(...), etc.
  CC.MoveTo dx * 0.05, dy * 0.95: CC.LineTo dx * 0.3, dy * 0.2
                                  CC.LineTo dx * 0.6, dy * 0.7
                                  CC.LineTo dx * 0.9, dy * 0.1
  CC.Stroke , Cairo.CreateSolidPatternLng(vbRed) 'stroke the line-path above in vbRed
End Sub

Private Sub UpdateTextWidgets()
  Dim oW As Object, W As cWidgetBase
  For Each oW In Chart.Widgets 'loop over all Child-Widgets on our Chart-Widget
    Set W = oW.Widget 'adjust also the relative position of the current Text-Widget(s) to the just updated ChartWidget-Dimensions
    If IsArray(W.Tag) Then W.Move W.Tag(0) * Chart.Widget.Width, W.Tag(1) * Chart.Widget.Height
    If TypeOf oW Is cwTextBox Then W.Moveable = tbiMove.Checked    '<- reflect the ToolBtn state in the Moveable-Prop of the TextBox-Widgets
    If TypeOf oW Is cwTextBox Then oW.Locked = Not tbiEdit.Checked '<- reflect the ToolBtn state in the Locked-Prop of the TextBox-Widgets
  Next
End Sub
 
'**** toolbar-Item-Click-Handlers
Private Sub tbiSave_Click()
  Dim W: W = Chart.Widget.BackBuffer.Width  'get the real Pixel-Width of our Chart-area (directly from its underlying BackBuffer)
  Dim H: H = Chart.Widget.BackBuffer.Height 'same for the Height
  With pnlCover.WidgetRoot.Surface 'and our Form-covering Main-Panel also contains a BackBuffer-Surface which holds everything (any Widget-Output)
    Dim ChartSrf As cCairoSurface '... but since we want only the content of the Chart-Area-widget (including the TextBoxes), ...
    Set ChartSrf = .CropSurface((.Width - W) / 2, (.Height - H) / 2, W, H) '... we have to "cut it out" from the larger Surface via CropSurface
    Dim FName$: FName = New_c.FSO.ShowSaveDialog(OFN_EXPLORER, New_c.FSO.GetSpecialFolder(CSIDL_MYPICTURES), , "Chart.png", , "png", hWnd)
    If Len(FName) Then ChartSrf.WriteContentToPngFile FName 'if we have a valid Filename, we can finally write out our PNG
  End With
End Sub
Private Sub tbiEdit_Click()
  UpdateTextWidgets
End Sub
Private Sub tbiMove_Click()
  UpdateTextWidgets
End Sub
'**** end of toolbar-item-handlers

'**** TextBox-Handling via the "central Bubbling-Handler" (which catches all the Events - from all the Widgets currently on the Panel)
'we use it here, to catch the Events of all "moving Chart-TextBoxes" in just one single Handler-routine
Private Sub pnlCover_BubblingEvent(Sender As Object, EventName As String, P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant, P5 As Variant, P6 As Variant, P7 As Variant)
  If TypeOf Sender Is cwTextBox And EventName = "W_Moving" Then HandleTextBoxMoving Sender.Widget
End Sub
Private Sub HandleTextBoxMoving(TBW As cWidgetBase) 'store the Left/Top-Coord of the given TBW relatively in its Tag-Prop
  TBW.Tag = Array(TBW.Left / Chart.Widget.Width, TBW.Top / Chart.Widget.Height)
End Sub
'**** end of TextBox-related handler-routines

'**** Statusbar-Helpers and -Events (starting with a construction-helper)
Function AddStatusItem(Caption, ImageKey, x, dx, Optional ByVal ForeColor&) As cwToolBarItem
  Set AddStatusItem = StatB.Widgets.Add(New cwToolBarItem, "stat" & StatB.Widgets.Count, 3 + x, 3, dx, StatB.Widget.Height - 5)
  With AddStatusItem
      .Caption = Caption: .Widget.ImageKey = ImageKey: .Widget.ForeColor = ForeColor
      .IsCheckable = True: .Checked = True: .IsCheckable = False 'this locks these Stat-Items in a "checked, inset State"
  End With
End Function

Function CreatePopUpEntriesForZoom() As cMenuItem 'dynamically generated MenuData for popZ (triggered in the Handler below)
  Set CreatePopUpEntriesForZoom = Cairo.CreateMenuItemRoot("popZ", "popZ")
      CreatePopUpEntriesForZoom.AddSubItem "100", "100%", "icoZoom"
      CreatePopUpEntriesForZoom.AddSubItem "125", "125%", "icoZoom"
      CreatePopUpEntriesForZoom.AddSubItem "150", "150%", "icoZoom"
      CreatePopUpEntriesForZoom.AddSubItem "200", "200%", "icoZoom"
      CreatePopUpEntriesForZoom.AddSubItem "250", "250%", "icoZoom"
End Function

Private Sub staZ_ArrowClick() 'for the StatusBar-Items, we pulled only one ("the Zoom-Entry") into a WithEvents-Variable
  popZ.InitAndShow staZ.Widget, CreatePopUpEntriesForZoom
End Sub
Private Sub popZ_Click(ByVal CurMenuItemPath As String) 'the passed CurMenuItemPath will be: "popZ>100" or "popZ>150"
  pnlCover.Locked = True
    pnlCover.WidgetRoot.Zoom = Split(CurMenuItemPath, ">")(1) / 100 'we use the split off the right part of the CurMenuItemPath directly
    pnlCover_ResizeWithDimensionsDIP pnlCover.ScaleWidthDIP, pnlCover.ScaleHeightDIP 'run through the pnlCover_Resize Event again, to adjust
    staZ.Caption = "Zoom: " & Format(pnlCover.WidgetRoot.Zoom, "0%")
  pnlCover.Locked = False
End Sub
'**** end of statusbar-related helper-routines

---

Have fun,

Olaf

Attached Images

 

MSHFlexGrid and RowSel bug?

January 24, 2022, 10:28 am

≫ Next: [VB6/VBA] WinXP compatible HMAC

≪ Previous: VB6 DPI-awareness via RC6/RC6Widgets (and Device-Independent-Pixels)

$

0

0

The problem is on 2 mshflexgrid linked at 2 table on msdatabase.
Clicking on first grid the selection on grid 2 is correct, but if 2 selection is empty then the rowsel on second grid fails!
On attached files the complete example.
Any help is appreciated!
Thanks

Attached Files

• TestFlexGrid.zip (13.7 KB)

[VB6/VBA] WinXP compatible HMAC

January 26, 2022, 3:11 am

≫ Next: Scrolling a Standard VB6 Listbox via VB6 API's

≪ Previous: MSHFlexGrid and RowSel bug?

$

0

0

The module includes a single GetHMAC function which can be used with all SHA-2, SHA1 and MD5 hashes.

The module is taken care to work in x64 VBA too and is compatible down to XP SP3.

Code:

---

'--- mdHmac.bas
Option Explicit
DefObj A-Z

#Const HasPtrSafe = (VBA7 <> 0)

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

'--- for CryptAcquireContext
Private Const PROV_RSA_AES                  As Long = 24
Private Const CRYPT_VERIFYCONTEXT          As Long = &HF0000000
'--- for CryptCreateHash
Private Const CALG_RC2                      As Long = &H6602&
Private Const CALG_MD5                      As Long = &H8003&
Private Const CALG_HMAC                    As Long = &H8009&
Private Const CALG_SHA1                    As Long = &H8004&
Private Const CALG_SHA_256                  As Long = &H800C&
Private Const CALG_SHA_384                  As Long = &H800D&
Private Const CALG_SHA_512                  As Long = &H800E&
'--- for CryptGet/SetHashParam
Private Const HP_HASHVAL                    As Long = 2
Private Const HP_HMAC_INFO                  As Long = 5
'--- for CryptImportKey
Private Const PLAINTEXTKEYBLOB              As Long = 8
Private Const CUR_BLOB_VERSION              As Long = 2
Private Const CRYPT_IPSEC_HMAC_KEY          As Long = &H100
Private Const LNG_FACILITY_WIN32            As Long = &H80070000

#If HasPtrSafe Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
'--- advapi32
Private Declare PtrSafe Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextW" (phProv As LongPtr, ByVal pszContainer As LongPtr, ByVal pszProvider As LongPtr, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptReleaseContext Lib "advapi32" (ByVal hProv As LongPtr, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptImportKey Lib "advapi32" (ByVal hProv As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As LongPtr, ByVal dwFlags As Long, phKey As LongPtr) As Long
Private Declare PtrSafe Function CryptDestroyKey Lib "advapi32" (ByVal hKey As LongPtr) As Long
Private Declare PtrSafe Function CryptGetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptSetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptCreateHash Lib "advapi32" (ByVal hProv As LongPtr, ByVal AlgId As Long, ByVal hKey As LongPtr, ByVal dwFlags As Long, phHash As LongPtr) As Long
Private Declare PtrSafe Function CryptHashData Lib "advapi32" (ByVal hHash As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CryptDestroyHash Lib "advapi32" (ByVal hHash As LongPtr) As Long
#Else
Private Enum LongPtr
    [_]
End Enum
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
'--- advapi32
Private Declare Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextW" (phProv As LongPtr, ByVal pszContainer As LongPtr, ByVal pszProvider As LongPtr, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32" (ByVal hProv As LongPtr, ByVal dwFlags As Long) As Long
Private Declare Function CryptImportKey Lib "advapi32" (ByVal hProv As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As LongPtr, ByVal dwFlags As Long, phKey As LongPtr) As Long
Private Declare Function CryptDestroyKey Lib "advapi32" (ByVal hKey As LongPtr) As Long
Private Declare Function CryptGetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptSetHashParam Lib "advapi32" (ByVal hHash As LongPtr, ByVal dwParam As Long, pbData As Any, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32" (ByVal hProv As LongPtr, ByVal AlgId As Long, ByVal hKey As LongPtr, ByVal dwFlags As Long, phHash As LongPtr) As Long
Private Declare Function CryptHashData Lib "advapi32" (ByVal hHash As LongPtr, pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32" (ByVal hHash As LongPtr) As Long
#End If

Private Type BLOBHEADER
    bType              As Byte
    bVersion            As Byte
    reserved            As Integer
    aiKeyAlg            As Long
    cbKeySize          As Long
    Buffer(0 To 255)    As Byte
End Type
Private Const sizeof_BLOBHEADER As Long = 12

Private Type HMAC_INFO
    HashAlgid          As Long
    pbInnerString      As LongPtr
    cbInnerString      As Long
    pbOuterString      As LongPtr
    cbOuterString      As Long
End Type

'=========================================================================
' Functions
'=========================================================================

Public Function GetHMAC(sAlgId As String, baPass() As Byte, baInput() As Byte, baRetVal() As Byte) As Boolean
    Dim lHashAlgId      As Long
    Dim lHashSize      As Long
    Dim hProv          As LongPtr
    Dim uBlob          As BLOBHEADER
    Dim hKey            As LongPtr
    Dim uInfo          As HMAC_INFO
    Dim hHash          As LongPtr
    Dim hResult        As Long
    Dim sApiSource      As String
   
    Select Case UCase$(sAlgId)
    Case "SHA256"
        lHashAlgId = CALG_SHA_256
        lHashSize = 32
    Case "SHA384"
        lHashAlgId = CALG_SHA_384
        lHashSize = 48
    Case "SHA512"
        lHashAlgId = CALG_SHA_512
        lHashSize = 64
    Case "MD5"
        lHashAlgId = CALG_MD5
        lHashSize = 16
    Case Else
        lHashAlgId = CALG_SHA1
        lHashSize = 20
    End Select
    If CryptAcquireContext(hProv, 0, 0, PROV_RSA_AES, CRYPT_VERIFYCONTEXT) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptAcquireContext"
        GoTo QH
    End If
    uBlob.bType = PLAINTEXTKEYBLOB
    uBlob.bVersion = CUR_BLOB_VERSION
    uBlob.aiKeyAlg = CALG_RC2
    Debug.Assert UBound(uBlob.Buffer) >= UBound(baPass)
    uBlob.cbKeySize = UBound(baPass) + 1
    Call CopyMemory(uBlob.Buffer(0), baPass(0), uBlob.cbKeySize)
    If CryptImportKey(hProv, uBlob, sizeof_BLOBHEADER + uBlob.cbKeySize, 0, CRYPT_IPSEC_HMAC_KEY, hKey) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptImportKey"
        GoTo QH
    End If
    If CryptCreateHash(hProv, CALG_HMAC, hKey, 0, hHash) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptCreateHash"
        GoTo QH
    End If
    uInfo.HashAlgid = lHashAlgId
    If CryptSetHashParam(hHash, HP_HMAC_INFO, uInfo, 0) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptSetHashParam(HP_HMAC_INFO)"
        GoTo QH
    End If
    If CryptHashData(hHash, baInput(0), UBound(baInput) + 1, 0) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptHashData"
        GoTo QH
    End If
    ReDim baRetVal(0 To lHashSize - 1) As Byte
    If CryptGetHashParam(hHash, HP_HASHVAL, baRetVal(0), UBound(baRetVal) + 1, 0) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptGetHashParam(HP_HASHVAL)"
        GoTo QH
    End If
    '--- success
    GetHMAC = True
QH:
    If hHash <> 0 Then
        Call CryptDestroyHash(hHash)
    End If
    If hKey <> 0 Then
        Call CryptDestroyKey(hKey)
    End If
    If hProv <> 0 Then
        Call CryptReleaseContext(hProv, 0)
    End If
    If LenB(sApiSource) <> 0 Then
        Err.Raise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), sApiSource
    End If
End Function

---

Test vectors for HMAC-SHA256 tests by dilletante

Code:

---

Option Explicit

Private Const TEST_KEYS As String = _
        "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b" & "0b0b0b0b|" _
      & "4a656665|" _
      & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaa|" _
      & "0102030405060708090a0b0c0d0e0f10" & "111213141516171819|" _
      & "0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c0c" & "0c0c0c0c|" _
      & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
      & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
      & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
      & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
      & "aaaaaa|" _
      & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
      & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
      & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
      & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" & "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" _
      & "aaaaaa"
Private Const TEST_DATA As String = _
        "4869205468657265|" _
      & "7768617420646f2079612077616e7420" & "666f72206e6f7468696e673f|" _
      & "dddddddddddddddddddddddddddddddd" & "dddddddddddddddddddddddddddddddd" _
      & "dddddddddddddddddddddddddddddddd" & "dddd|" _
      & "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd" & "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd" _
      & "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd" & "cdcd|" _
      & "546573742057697468205472756e6361" & "74696f6e|" _
      & "54657374205573696e67204c61726765" & "72205468616e20426c6f636b2d53697a" _
      & "65204b6579202d2048617368204b6579" & "204669727374|" _
      & "54686973206973206120746573742075" & "73696e672061206c6172676572207468" _
      & "616e20626c6f636b2d73697a65206b65" & "7920616e642061206c61726765722074" _
      & "68616e20626c6f636b2d73697a652064" & "6174612e20546865206b6579206e6565" _
      & "647320746f2062652068617368656420" & "6265666f7265206265696e6720757365" _
      & "642062792074686520484d414320616c" & "676f726974686d2e"
Private Const TEST_EXPECTED As String = _
        "b0344c61d8db38535ca8afceaf0bf12b" & "881dc200c9833da726e9376c2e32cff7|" _
      & "5bdcc146bf60754e6a042426089575c7" & "5a003f089d2739839dec58b964ec3843|" _
      & "773ea91e36800e46854db8ebd09181a7" & "2959098b3ef8c122d9635514ced565fe|" _
      & "82558a389a443c0ea4cc819899f2083a" & "85f0faa3e578f8077a2e3ff46729665b|" _
      & "a3b6167473100ee06e0c796c2955552b|" _
      & "60e431591ee0b67f0d8a26aacbf5b77f" & "8e0bc6213728c5140546040f0ee37f54|" _
      & "9b09ffa71b942fcb27635fbcd5b0e944" & "bfdc63644f0713938a7f51535c3a35e2"
     
Private Sub Command1_Click()
    Dim baPass()        As Byte
    Dim baInput()      As Byte
    Dim baOutput()      As Byte
   
    On Error GoTo EH
    baPass = StrConv("password123", vbFromUnicode)
    baInput = StrConv("test", vbFromUnicode)
    If GetHMAC("SHA512", baPass, baInput, baOutput) Then
        MsgBox ToHex(baOutput), vbExclamation
    End If
    Exit Sub
EH:
    MsgBox "Critical error: " & Err.Description, vbCritical
End Sub

Private Sub Form_Load()
    Dim vElem          As Variant
    Dim baHmac()        As Byte
   
    On Error GoTo EH
    For Each vElem In pvEnumTests()
        If GetHMAC("SHA256", FromHex(vElem(0)), FromHex(vElem(1)), baHmac) Then
            If Not StrComp(Left$(ToHex(baHmac, ""), Len(vElem(2))), vElem(2), vbTextCompare) = 0 Then
                MsgBox ToHex(baHmac, "") & vbCrLf & "<>" & vbCrLf & UCase$(vElem(2)), vbExclamation, "Assert failed"
            End If
        End If
    Next
    Exit Sub
EH:
    MsgBox "Critical error: " & Err.Description, vbCritical
End Sub

Private Function pvEnumTests() As Variant
    Dim vSplit          As Variant
    Dim lSize          As Long
    Dim vRetVal        As Variant
    Dim lIdx            As Long
   
    vSplit = Split(TEST_KEYS & "|" & TEST_DATA & "|" & TEST_EXPECTED, "|")
    lSize = (UBound(vSplit) + 1) \ 3
    ReDim vRetVal(0 To lSize - 1) As Variant
    For lIdx = 0 To UBound(vRetVal)
        vRetVal(lIdx) = Array(vSplit(lIdx), vSplit(lIdx + lSize), vSplit(lIdx + 2 * lSize))
    Next
    pvEnumTests = vRetVal
End Function

Public Function FromHex(ByVal sText As String) As Byte()
    Dim baRetVal()      As Byte
    Dim lIdx            As Long
   
    On Error GoTo QH
    '--- check for hexdump delimiter
    If sText Like "*[!0-9A-Fa-f]*" Then
        ReDim baRetVal(0 To Len(sText) \ 3) As Byte
        For lIdx = 1 To Len(sText) Step 3
            baRetVal(lIdx \ 3) = "&H" & Mid$(sText, lIdx, 2)
        Next
    ElseIf LenB(sText) <> 0 Then
        ReDim baRetVal(0 To Len(sText) \ 2 - 1) As Byte
        For lIdx = 1 To Len(sText) Step 2
            baRetVal(lIdx \ 2) = "&H" & Mid$(sText, lIdx, 2)
        Next
    Else
        baRetVal = vbNullString
    End If
    FromHex = baRetVal
QH:
End Function

Public Function ToHex(baText() As Byte, Optional Delimiter As String = "-") As String
    Dim aText()        As String
    Dim lIdx            As Long
   
    If LenB(CStr(baText)) <> 0 Then
        ReDim aText(0 To UBound(baText)) As String
        For lIdx = 0 To UBound(baText)
            aText(lIdx) = Right$("0" & Hex$(baText(lIdx)), 2)
        Next
        ToHex = Join(aText, Delimiter)
    End If
End Function

---

cheers,
</wqw>

Scrolling a Standard VB6 Listbox via VB6 API's

January 29, 2022, 12:19 pm

≫ Next: [VB6] BiArc Interpolation

≪ Previous: [VB6/VBA] WinXP compatible HMAC

$

0

0

This is a simple way of scrolling a standard VB6 ListBox Control via API functions

Attached Files

• listbox.zip (2.4 KB)

[VB6] BiArc Interpolation

January 31, 2022, 3:05 am

≫ Next: [VB6] VbVst - VST2.x framework for VB6.

≪ Previous: Scrolling a Standard VB6 Listbox via VB6 API's

$

0

0

Some time ago I came across this wonderful and detailed article about BiArc-Interpolation. BIARC
In it there is also source code that I ported to VB6.
Unlike years ago maybe today I would have written it a little differently and better, anyway the sharing of it could be interesting.

Quote:

---

Why would you want a circular interpolation? One reason might be that it is pleasing to eye, but it also has some practical use. If you are making a level editing tool that places roads (or making a game with procedural roads), you will may want turns to resemble their real-world counterparts. A second example, and the one I most often run across, is generating trails behind swords. Sword swings are often animated very fast. You only get a few sample points as the sword arcs through the attack. If you play the animation in slow motion, you'll find that the tip of the sword takes a rather circular path. By generating circular arcs between the sample points, a clean trail can be generated.

---

DOWNLOAD: GitHub Repo

(vbRichClient RC required)

[VB6] VbVst - VST2.x framework for VB6.

February 12, 2022, 4:02 pm

≫ Next: Vesta - A prototype software for Photon-pixel coupling method

≪ Previous: [VB6] BiArc Interpolation

$

0

0

Hello everyone!

This framework allows you to create VST 2.X plugins (so far only the effects) in VB6.



https://github.com/thetrik/VbVst

---

Vesta - A prototype software for Photon-pixel coupling method

February 26, 2022, 8:53 am

≫ Next: WebCam software sampling

≪ Previous: [VB6] VbVst - VST2.x framework for VB6.

$

0

0

Photon-pixel coupling is a novel method that allows a parallel sampling of an unlimited number of sensors. In the case shown here, 200 sensors are sampled in parallel at video rate frequency. The Vesta software shown below, analizes consecutive images from a special folder. Previously, this folder is filled up with images from a dedicated WebCam software. The Vesta implementation is made in Visual Basic 6.0 (VB6).


Download: Vesta - A prototype software for Photon-pixel coupling method





The setup:

Attached Images

  

WebCam software sampling

February 26, 2022, 9:10 am

≫ Next: Mapping pixels to LEDs (Photon-pixel coupling)

≪ Previous: Vesta - A prototype software for Photon-pixel coupling method

$

0

0

This is a WebCam software used in the Photon-pixel coupling method. The WebCam software takes images at equal intervals (user defined) and saves them as BMP files in a dedicated folder. These saved files are later used in the analysis by a software called Vesta. The WebCam application is made in Visual Basic 6.0 (VB6). For more information, please read: Photon-pixel coupling: A method for parallel acquisition of electrical signals in scientific investigations


Download: WebCam software sampling

Attached Images

  

Mapping pixels to LEDs (Photon-pixel coupling)

February 26, 2022, 11:03 am

≫ Next: Dynamic Block Allocation (DBA) algorithm

≪ Previous: WebCam software sampling

$

0

0

A webcam films an array of LEDs as seen in the image below. In each frame, these LEDs represent the output of different sensors and may have a variable brightness. Thus, this brightness must be converted to numerical values for analysis. But which pixel from the image is the most representative for an LED brightness? The positions of the LEDs are relative to the position of the camcorder. Thus, this software allows you to set the position of each LED over an image, as well as the pixel representative for brightness. The coordinates of each LED position is recorded as a string inside an array variable. The array variable is printed as a VB6 source code in a textbox object. Next, the content of the textbox object is manually copied inside the VB6 source code of the Vesta software (please look at the source code in the Vesta software).


Download: Mapping pixels to LEDs (Photon-pixel coupling)

Attached Images

  

Dynamic Block Allocation (DBA) algorithm

February 26, 2022, 12:53 pm

≫ Next: Discrete Probability Detector in VB6

≪ Previous: Mapping pixels to LEDs (Photon-pixel coupling)

$

0

0

Dynamic Block Allocation Algorithm [Double Brute Force (DBFA) and Multi Brute Force (MBFA)]. The Dynamic Block Allocation (DBA) algorithm represents a flexible method for partitioning string sequences into data blocks taking into account different rules imposed by a function. Two versions of this algorithm are presented, namely DBFA (Double Brute Force Algorithm) and MBFA (Multi Brute Force Algorithm). These algorithms are originally written in Visual Basic 6.0. The ZIP package contains four applications. These applications cover both the experiments performed with this algorithm and a small implementation.


Download: Dynamic Block Allocation (DBA) algorithm

Attached Images

  

Discrete Probability Detector in VB6

February 26, 2022, 1:31 pm

≫ Next: Discrete Probability Detector in [VB6, VBA, JS]

≪ Previous: Dynamic Block Allocation (DBA) algorithm

$

0

0

Discrete Probability Detector (DPD) is an algorithm that transforms any sequence of symbols into a transition matrix. The algorithm may receive special characters from the entire ASCII range. These characters can be letters, numbers or special characters (ie. `7Eu9f$*"). The number of symbol/character types that make up a string, represent the number of states in a Markov chain. Thus, DPD is able to detect the number of states from the sequence and calculate the transition probabilities between these states. The final result of the algorithm is represented by a transition matrix (square matrix) which contains the transition probabilities between these symbol types (or states). The transition matrix can be further used for different prediction methods, such as Markov chains or Hidden Markov Models. This version of DPD is made in Visual Basic 6.0.


Download: Discrete Probability Detector in VB6

Attached Images