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

FastSort for bytes

$
0
0
Here's my Histogram based FastSort function for bytes. Unlike normal Sort type algorithms, which require often many passes (the exact number depending on the exact arangement of numbers in the array) over a set of data, while swapping entries in the array, this one takes just 2 passes. The pass to creates the histogram from the input byte array, and the second one reads bytes out of the histogram into the output array. Unfortunately this won't work on Single and Double precision floating point values, as you can't have a histogram array with a fractional index (whole number indices only are allowed), it actually works great on integer data types. The one shown below is intended specifically with the Byte data type, but it should be fairly easy to modify it to work with Integer data type (though with the Long data type there would be a problem unless you limited the range, as it would take 16 gigabytes of ram, and so is not possible to implement in VB6, nor would it work even on most computers, as most computers don't have over 16GB of ram in them, as would be needed to hold both the Windows OS and the huge histogram).

Code:

Private Function FastSort(ByRef ArrayIn() As Byte) As Byte()
Dim ArrayOut() As Byte
Dim Histogram(255) As Long
Dim n As Long
Dim m As Long
Dim m2 As Long

ReDim ArrayOut(UBound(ArrayIn))
For n = 0 To UBound(ArrayIn)
    Histogram(ArrayIn(n)) = Histogram(ArrayIn(n)) + 1
Next n

For n = 0 To 255
    For m = 1 To Histogram(n)
        ArrayOut(m2) = n
        m2 = m2 + 1
    Next m
Next n
FastSort = ArrayOut()
End Function




Update:
I have discovered something very interesting. When used with small sized data sets (such as when sorting to find the median value of a 3x3 array of pixels), the byte-swapping Sort algorithm is actually faster than my histogram based FastSort algorithm.

[VB6] - Store data to EXE.

$
0
0
Hello everyone!
There are times when you want to save the data after completion of the program, but did not want to have external dependencies, registry entries, etc. However you can store the data in your EXE. Unfortunately, Windows doesn't allow to write into the running EXE (i don't consider NTFS streams), and any attempt of the writing will be rejected with the ERROR_ACCESS_DENIED error. Although if the process is complete it can be performed by another process. Here is the way I decided to choose.
Firstly, you'd run cmd.exe with the suspended state. Further you'd create code that will be injected to it and will change the resources of our EXE. Then you'd run this code. This code waits for termination of our process and then rewrites the needed data (you've passed them to there). Eventually it is terminated.
In order to simplify the code (it only needs single form) i decide to make it in assembler. It is simpler and requires less code (source is included). Because the code is published especially for the review and test, it doesn't perform any synchronizations.
Code:

' Store data to EXE
' © Krivous Anatolii Anatolevich (The trick), 2014
' Writing is performed only after process termination

Option Explicit

Private Type STARTUPINFO
    cb              As Long
    lpReserved      As Long
    lpDesktop      As Long
    lpTitle        As Long
    dwX            As Long
    dwY            As Long
    dwXSize        As Long
    dwYSize        As Long
    dwXCountChars  As Long
    dwYCountChars  As Long
    dwFillAttribute As Long
    dwFlags        As Long
    wShowWindow    As Integer
    cbReserved2    As Integer
    lpReserved2    As Long
    hStdInput      As Long
    hStdOutput      As Long
    hStdError      As Long
End Type

Private Type PROCESS_INFORMATION
    hProcess        As Long
    hThread        As Long
    dwProcessId    As Long
    dwThreadId      As Long
End Type

Private Type ThreadData
    hParent        As Long
    lpFileName      As Long
    lpRsrcName      As Long
    lpData          As Long
    dwDataCount    As Long
    lpWFSO          As Long
    lpCH            As Long
    lpBUR          As Long
    lpUR            As Long
    lpEUR          As Long
    lpEP            As Long
End Type

Private Declare Function CloseHandle Lib "kernel32" ( _
                        ByVal hObject As Long) As Long
Private Declare Function CreateProcess Lib "kernel32" _
                        Alias "CreateProcessW" ( _
                        ByVal lpApplicationName As Long, _
                        ByVal lpCommandLine As Long, _
                        lpProcessAttributes As Any, _
                        lpThreadAttributes As Any, _
                        ByVal bInheritHandles As Long, _
                        ByVal dwCreationFlags As Long, _
                        lpEnvironment As Any, _
                        ByVal lpCurrentDirectory As Long, _
                        lpStartupInfo As STARTUPINFO, _
                        lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function GetModuleHandle Lib "kernel32" _
                        Alias "GetModuleHandleA" ( _
                        ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" ( _
                        ByVal hModule As Long, _
                        ByVal lpProcName As String) As Long
Private Declare Function DuplicateHandle Lib "kernel32" ( _
                        ByVal hSourceProcessHandle As Long, _
                        ByVal hSourceHandle As Long, _
                        ByVal hTargetProcessHandle As Long, _
                        lpTargetHandle As Long, _
                        ByVal dwDesiredAccess As Long, _
                        ByVal bInheritHandle As Long, _
                        ByVal dwOptions As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function VirtualAllocEx Lib "kernel32.dll" ( _
                        ByVal hProcess As Long, _
                        lpAddress As Any, _
                        ByVal dwSize As Long, _
                        ByVal flAllocationType As Long, _
                        ByVal flProtect As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" ( _
                        ByVal hProcess As Long, _
                        ByVal lpBaseAddress As Long, _
                        lpBuffer As Any, _
                        ByVal nSize As Long, _
                        lpNumberOfBytesWritten As Long) As Long
Private Declare Function GetMem4 Lib "msvbvm60" ( _
                        src As Any, _
                        dst As Any) As Long
Private Declare Function VirtualFreeEx Lib "kernel32.dll" ( _
                        ByVal hProcess As Long, _
                        lpAddress As Any, _
                        ByVal dwSize As Long, _
                        ByVal dwFreeType As Long) As Long
Private Declare Function CreateRemoteThread Lib "kernel32" ( _
                        ByVal hProcess As Long, _
                        lpThreadAttributes As Any, _
                        ByVal dwStackSize As Long, _
                        ByVal lpStartAddress As Long, _
                        lpParameter As Any, _
                        ByVal dwCreationFlags As Long, _
                        lpThreadId As Long) As Long
Private Declare Function FindResource Lib "kernel32" _
                        Alias "FindResourceW" ( _
                        ByVal hInstance As Long, _
                        ByVal lpName As Long, _
                        ByVal lpType As Long) As Long
Private Declare Function LoadResource Lib "kernel32" ( _
                        ByVal hInstance As Long, _
                        ByVal hResInfo As Long) As Long
Private Declare Function LockResource Lib "kernel32" ( _
                        ByVal hResData As Long) As Long
Private Declare Function SizeofResource Lib "kernel32" ( _
                        ByVal hInstance As Long, _
                        ByVal hResInfo As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
                        Alias "RtlMoveMemory" ( _
                        Destination As Any, _
                        Source As Any, _
                        ByVal Length As Long)

Private Const STARTF_USESHOWWINDOW      As Long = &H1
Private Const SW_HIDE                  As Long = 0
Private Const MEM_COMMIT                As Long = &H1000&
Private Const MEM_RESERVE              As Long = &H2000&
Private Const MEM_RELEASE              As Long = &H8000&
Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&
Private Const INFINITE                  As Long = -1&
Private Const MAX_PATH                  As Long = 260
Private Const RT_RCDATA                As Long = 10&
Private Const CREATE_SUSPENDED          As Long = &H4
Private Const DUPLICATE_SAME_ACCESS    As Long = &H2
Private Const ResName                  As String = "TRICKRESOURCE" & vbNullChar    ' Only capital letters

' // Procedure load data from EXE
Private Sub LoadFromEXE()
    Dim hRes As Long, hMem As Long, ptr As Long, l As Long, Msg As String
   
    hRes = FindResource(0, StrPtr(ResName), RT_RCDATA)
   
    If hRes Then
        hMem = LoadResource(0, hRes)
        If hMem Then
            l = SizeofResource(0, hRes)
            If l Then
                ptr = LockResource(hMem)
                GetMem4 ByVal ptr, l
                Msg = Space(l \ 2)
                CopyMemory ByVal StrPtr(Msg), ByVal ptr + 4, l
                txtData.Text = Msg
            End If
        End If
    End If
   
End Sub

' // Procedure store data to EXE
Private Sub StoreToExe()
    Dim hLib As Long
    Dim td As ThreadData, ts As Long, path As String, pi As PROCESS_INFORMATION, si As STARTUPINFO, hProc As Long, lpDat As Long, pt As Long
    Dim Code() As Byte, Data() As Byte, ret As Long, thr As Long, otd As Long
   
    ' // Get the Kernel32 handle
    hLib = GetModuleHandle("kernel32")
    If hLib = 0 Then MsgBox "Error": Exit Sub
   
    ' // Get the functions addresses
    td.lpWFSO = GetProcAddress(hLib, "WaitForSingleObject")
    td.lpCH = GetProcAddress(hLib, "CloseHandle")
    td.lpBUR = GetProcAddress(hLib, "BeginUpdateResourceW")
    td.lpUR = GetProcAddress(hLib, "UpdateResourceW")
    td.lpEUR = GetProcAddress(hLib, "EndUpdateResourceW")
    td.lpEP = GetProcAddress(hLib, "ExitProcess")
   
    path = App.path & "\" & App.EXEName & ".exe" & vbNullChar
   
    ' // Create the machine code
    CreateCode Code
   
    ' // Calculate size of the needed memory
    ts = LenB(path) + LenB(ResName) + (UBound(Code) + 1) + LenB(txtData.Text) + Len(td) + 4
   
    si.cb = Len(si)
    si.dwFlags = STARTF_USESHOWWINDOW
    si.wShowWindow = SW_HIDE
   
    ' // Launch "victim" (CMD.EXE)
    If CreateProcess(StrPtr(Environ("ComSpec")), 0, ByVal 0&, ByVal 0&, False, CREATE_SUSPENDED, ByVal 0, 0, si, pi) = 0 Then
        MsgBox "error": Exit Sub
    End If
   
    ' // Get handle of the our process for CMD process
    hProc = GetCurrentProcess()
    DuplicateHandle hProc, hProc, pi.hProcess, td.hParent, 0, False, DUPLICATE_SAME_ACCESS
   
    td.dwDataCount = LenB(txtData.Text) + 4        ' Размер данных
   
    ' // Allocate memory in the CMD
    lpDat = VirtualAllocEx(pi.hProcess, ByVal 0, ts, MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE)
   
    If lpDat = 0 Then
        MsgBox "Error": CloseHandle pi.hThread: CloseHandle pi.hProcess
        VirtualFreeEx pi.hProcess, ByVal lpDat, 0, MEM_RELEASE
        Exit Sub
    End If
   
    ' // Ok, all is ready for the writing to cmd
    ' // Create buffer with data
    ReDim Data(ts - 1)
   
    ' // Copy the file name of our process
    CopyMemory Data(pt), ByVal StrPtr(path), LenB(path)
    td.lpFileName = lpDat + pt: pt = pt + LenB(path)
    ' // Copy the name of the resource
    CopyMemory Data(pt), ByVal StrPtr(ResName), LenB(ResName)
    td.lpRsrcName = lpDat + pt: pt = pt + LenB(ResName)
    ' // Copy the data of the resource
    GetMem4 LenB(txtData.Text), Data(pt)          ' Размер
    CopyMemory Data(pt + 4), ByVal StrPtr(txtData.Text), LenB(txtData.Text)
    td.lpData = lpDat + pt: pt = pt + LenB(txtData.Text) + 4
    ' // Copy the structure to buffer
    CopyMemory Data(pt), td, Len(td): otd = pt: pt = pt + Len(td)
    ' // Copy the code
    CopyMemory Data(pt), Code(0), UBound(Code) + 1
   
    ' // Buffer is ready, inject it to cmd
    If WriteProcessMemory(pi.hProcess, lpDat, Data(0), ts, ret) Then
        If ret <> ts Then
            MsgBox "Error": CloseHandle pi.hThread: CloseHandle pi.hProcess
            VirtualFreeEx pi.hProcess, ByVal lpDat, 0, MEM_RELEASE
            Exit Sub
        End If
        ' // Launch the injected code
        thr = CreateRemoteThread(pi.hProcess, ByVal 0, 0, lpDat + pt, ByVal lpDat + otd, 0, 0)
        If thr = 0 Then
            MsgBox "Error": CloseHandle pi.hThread: CloseHandle pi.hProcess
            VirtualFreeEx pi.hProcess, ByVal lpDat, 0, MEM_RELEASE
            Exit Sub
        End If
    End If
   
    ' // Close handles
    CloseHandle thr
    CloseHandle pi.hThread
    CloseHandle pi.hProcess
   
End Sub

Private Sub CreateCode(Code() As Byte)
    ReDim Code(63)
    Code(0) = &H8B: Code(1) = &H74: Code(2) = &H24: Code(3) = &H4: Code(4) = &H31: Code(5) = &HDB: Code(6) = &H53: Code(7) = &H6A
    Code(8) = &HFF: Code(9) = &HFF: Code(10) = &H36: Code(11) = &HFF: Code(12) = &H56: Code(13) = &H14: Code(14) = &HFF: Code(15) = &H36
    Code(16) = &HFF: Code(17) = &H56: Code(18) = &H18: Code(19) = &H53: Code(20) = &HFF: Code(21) = &H76: Code(22) = &H4: Code(23) = &HFF
    Code(24) = &H56: Code(25) = &H1C: Code(26) = &H89: Code(27) = &H4: Code(28) = &H24: Code(29) = &H85: Code(30) = &HC0: Code(31) = &H74
    Code(32) = &H1B: Code(33) = &HFF: Code(34) = &H76: Code(35) = &H10: Code(36) = &HFF: Code(37) = &H76: Code(38) = &HC: Code(39) = &H53
    Code(40) = &HFF: Code(41) = &H76: Code(42) = &H8: Code(43) = &H6A: Code(44) = &HA: Code(45) = &HFF: Code(46) = &H74: Code(47) = &H24
    Code(48) = &H14: Code(49) = &HFF: Code(50) = &H56: Code(51) = &H20: Code(52) = &H53: Code(53) = &HFF: Code(54) = &H74: Code(55) = &H24
    Code(56) = &H4: Code(57) = &HFF: Code(58) = &H56: Code(59) = &H24: Code(60) = &H53: Code(61) = &HFF: Code(62) = &H56: Code(63) = &H28
End Sub

Private Sub Form_Load()
    LoadFromEXE
End Sub

Private Sub Form_Unload(Cancel As Integer)
    StoreToExe
End Sub

'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ This procedure is running in other process \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

' Similar code in VB6

'Private Sub ThreadProc(dat As ThreadData)
'    Dim hRes As Long
'    ' Wait for the termination of the main process
'    WaitForSingleObject dat.hParent, INFINITE
'    ' Process has ended, close handle
'    CloseHandle dat.hParent
'    ' Get handle of the editing of the resource
'    hRes = BeginUpdateResource(dat.lpFileName, False)
'    If hRes Then
'      ' Wirte the needed data to EXE
'      UpdateResource hRes, RT_RCDATA, dat.lpRsrcName, 0, ByVal dat.lpData, dat.dwDataCount
'      ' Ending of the updating
'      EndUpdateResource hRes, False
'    End if
'      ' Done !!!
'    ExitProcess 0
'End Sub

' Assembly code (NASM)

'[BITS 32]
'; ThreadProc
'mov esi,dword [esp+0x04]; ESI = &dat
'xor ebx,ebx            ; Const 0&
'push ebx                ; Dim hRes As Long
'push 0xFFFFFFFF        ; INFINITE
'push dword [esi+0x00]  ; dat.hParent
'call [esi+0x14]        ; WaitForSingleObject dat.hParent, INFINITE
'push dword [esi+0x00]  ; dat.hParent
'call [esi+0x18]        ; CloseHandle dat.hParent
'push ebx                ; False
'push dword [esi+0x04]  ; dat.lpFileName
'call [esi+0x1c]        ; BeginUpdateResource(dat.lpFileName, False)
'mov [esp],eax          ; hRes = eax
'test eax,eax            ; IF hRes=0
'je ExtProc              ; GoTo ExtProc
'push dword [esi+0x10]  ; dat.dwDataCount
'push dword [esi+0x0c]  ; dat.lpData
'push ebx                ; 0
'push dword [esi+0x08]  ; dat.lpRsrcName
'push 0x0000000a        ; RT_RCDATA
'push dword [esp+0x14]  ; hRes
'call [esi+0x20]        ; UpdateResource hRes, RT_RCDATA, dat.lpRsrcName, 0, ByVal dat.lpData, dat.dwDataCount
'push ebx                ; False
'push dword [esp+0x04]  ; hRes
'call [esi+0x24]        ; EndUpdateResource hRes, False
'ExtProc:
'push ebx                ; 0
'call [esi+0x28]        ; ExitProcess 0

Attached Files

VB6 - Fast Sqr

$
0
0
Internal VB6 Sqr() function is very slow

Here is my FastSqr() function

N>=0

Code:

Public Function FASTsqr(n As Double) As Double
    Dim X      As Double
    Dim oldX    As Double

    If n Then
        'EDIT:
        'X = n * 0.25
        X = n * 0.5
        Do
            oldX = X
            X = (X + (n / X)) * 0.5
        Loop While oldX <> X

        FASTsqr = X
    End If

End Function

VB6 Simple FTP-Client (PASV-mode, based on Winsock.ocx)

$
0
0
As the title says -
not much to comment - other than that it's a quite old code-base
(though slightly revised now - and still working with most FTP-Servers).

Source-Code: FTP-revised2.zip

ScreenShot:



Have fun with it,

Olaf
Attached Files

[VB6] - Wave steganography.

$
0
0
Hi everyone!
Today i want to talk about the cryptography. I've made the example of using the special cryptography - the steganography. This method hides the fact of encryption of the data. There are lot of kinds of the steganography. Today i'll talk about LSB-method when data is hided into the least significant bits of the audio file. It looks as though you are exchanged a audio files, but really you send a secret data. People who don't know about this method they will not even suspect about secret data. In some cases it can be very useful.
How does it work?
A WAVE-PCM file (without a compressions) contains sound data. Really the sound is an analog event, i.e. continuous. In order to convert it to digital form you should quantize it with lossy. This process is characterized by two parameters: bitness and sample per second. "Bitness" affects to how many levels can it contains in each sample. "Sample per second" affects to how many frequencies do you can hear:
Name:  Pic1.png
Views: 37
Size:  37.4 KB
In this case we are interested only the bitness of an audio. It can be 32, 24, 16, .... bits per each sample. Main idea of steganography (in this case) is rewrite the least significant bits to our data. The more you overwrite bits the greater the distortion.
This picture explains it graphically:
Name:  pic2.png
Views: 40
Size:  28.4 KB
As you can see, it stores all hidden data to certain bits in the audio data (in this picture 4 bits to each sample). Also note that for storing the data you need to use the bigger file size than the source file. For instance, if you use 3 bit for the decoding the result file will have the size that is 16/3 times greater than source. I've said 16 because i use the 16 bps wave file in my example.
In the attached example i also save the original file name. In general, format of the data is described in the picture:
Name:  pic3.png
Views: 35
Size:  20.8 KB
When the packing occurs it gets each byte from the source file. Then the subroutine extracts the necessary bits from the source file and clears corresponding bits in the audio data. Further the subroutine sets bits using bitwise-OR operator. For extracting the necessary bits it uses the masks and the shifts. The mask leaves necessary bits and the shift places them to the beginning of the byte.
Unpacking works vice versa. It extracts bits from audio data and builds file using corresponding bits.
Hope the review will be useful.
Thanks for attention.
Regards,
Кривоус Анатолий.
Attached Images
   
Attached Files

BSTR2LPSTR and LPSTR2BSTR conversions for VB6

$
0
0
The problem with a number of API functions is that they return strings as LPSTR. An LPSTR is a pointer to a string in memory that is terminated with null (0x00 byte), and the strings themselves are in an ANSI format, not UNICODE. And the string length isn't stored anywhere. Meanwhile in VB6, its strings are of the BSTR type. These are pointers to UNICODE strings, and while these are terminated with a unicode null (0x0000 word), they also have a byte count in the 4 bytes before the start of the string. Note that this does not include the 2 byte null at the end.

To convert between LPSTR and BSTR, I've created these 2 functions. Put the below code into a module in VB6.
Code:

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)



Public Sub BSTR2LPSTR(ByVal BSTR As String, ByVal LPSTR As Long)
Dim STR() As Byte
STR() = StrConv(BSTR & vbNullChar, vbFromUnicode)
CopyMemory ByVal LPSTR, STR(0), UBound(STR) + 1
End Sub



Public Function LPSTR2BSTR(ByVal LPSTR As Long, Optional ByVal NullSearchDist As Long = 256) As String
Dim STR() As Byte
Dim NullOffset As Long
Dim StrLen As Long

ReDim STR(NullSearchDist - 1)
CopyMemory STR(0), ByVal LPSTR, NullSearchDist

NullOffset = InStrB(1, STR, vbNullChar) - 1
Select Case NullOffset
    Case -1
        StrLen = NullSearchDist
    Case 0
        StrLen = 1
    Case Else
        StrLen = NullOffset
End Select
ReDim Preserve STR(StrLen - 1)
LPSTR2BSTR = StrConv(STR, vbUnicode)
End Function


To test out these functions, put the below code into your Form1, and make sure the AutoRedraw property is set to True for Form1, then run the program.
Code:

Private Sub Form_Load()
Dim a As String
Dim b() As Byte
Dim ptrb As Long
Dim c As String
Dim n As Long

ReDim b(255)
ptrb = VarPtr(b(0))

a = "This is a test."

BSTR2LPSTR a, ptrb
c = LPSTR2BSTR(ptrb)

Print a
For n = 0 To 255
    If b(n) = 0 Then Exit For
    Print Chr$(b(n));
Next n
Print ""
Print c
Print Len(a)
Print UBound(b) + 1
Print Len(c)
End Sub

If it is working correctly on your computer, the sentence "This is a test." should appear 3 times on the form, and then the numbers 15, 256, and 15 should appear. The 2 15s are the sizes of the original BSTR string, and BSTR string that was created from the LPSTR string that was created from the original BSTR string. The 256 is the size of the block of memory in which the LPSTR was stored. The block of memory in which the string that pointed to by the LPSTR is stored, must be no smaller than the length of the string, but it can be larger than that length without a problem (as this program demonstrates).

[vb6] PropertyBag, Persisting, Cloning for UserControls

$
0
0
With VB, we have the use of the PropertyBag object. It is used in usercontrols to persist settings and can be used in public classes (within DLL,OCX projects) that have the Persistable property set to true.

What is shown below is nothing new, but maybe just a different way of doing it, from a UserControl perspective.

The usercontrol, and maybe some classes that you create, have a ReadProperties and WriteProperties event. These events are called when the object is being created (InitProperties,ReadProperties) and destroyed/saved (WriteProperties).

In your usercontrol project, you may have several classes also. Some of these classes have data that needs to be saved to the usercontrol. When the usercontrol is loaded, the class is created and that data loaded into the class. By using a property bag, whether your class has the Persistable property set to true or not, you can persist the data. Additionally, the user can have the option to "export" the class data so they can save it where/when they wish. The user could also "import" the data into the class from a previously saved state.

In my hypothetical usercontrol (UCWidget), I have several classes, some of which the user can create, modify, then assign to UCWidget via properties. One such hypothetical class is IAttributes. The IAttributes class is accessed via UCWidget.Attributes property directly during runtime and indirectly during design-time via the property page.

The IAttributes class, along with all classes to be persisted, within the UCWidget, project has an Export and Import sub. That sub is either Public or Friend declared. Public versions allow importing/exporting by both the UCWidget control and/or the user. The Friend declared versions only allow the UCWidget to do the import/export. The functions look like this:
Code:

Public Sub Export(PropBag As PropertyBag)
    If PropBag Is Nothing Then Set PropBag = New PropertyBag
    ' save all class settings to the property bag, exactly same as a usercontrol's WriteProperties event
End Sub

Public Sub Import(PropBag As PropertyBag)
    If PropBag Is Nothing Then
        ' optional: reset all properties to default, exactly same as a usercontrol's InitProperties event
    Else
        ' read all class settings from the property bag, exactly same as a usercontrol's ReadProperties event
    End If
End Sub

A user, during runtime, can import/export via a property bag:
Code:

' export example
    Dim myBag As PropertyBag
    UCWidget1.Attributes.Export myBag ' export the IAttributes class data
    ' save myBag.Contents to file. Contents can be assigned to a  byte array if desired

' import example
    Dim myBag As PropertyBag
    ' read previously saved data to array: byteData() As Byte
    Set myBag = New PropertyBag
    myBag.Contents = byteData(): Erase byteData()
    UCWidget1.Attributes.Import myBag ' import data into the IAttributes class

Likewise, the UCWidget control itself can serialize IAttributes during its Read/WriteProperties event:
Code:

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Dim pBag As PropertyBag
    m_Attributes.Export pBag ' m_Attributes is the UCWidget's class instance of IAttributes
    PropBag.Write "Attrs", pBag.Contents
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Dim pBag As PropertyBag
    Set pBag = New PropertyBag
    pBag.Contents = PropBag.ReadProperty("Attrs")
    m_Attributes.Import pBag ' m_Attributes is the UCWidget's class instance of IAttributes
    ' m_Attributes set to new instance during UserControl_Initialize
End Sub

The same approach can be used to clone anything in your usercontrol project. For example, cloning an IAttributes class and assigning it to a different UCWidget control.
Code:

    Dim pBag As PropertyBag
    UCWidgetA.Attributes.Export pBag
    UCWidgetB.Attributes.Import pBag

We can even clone the entire UCWidget to another UCWidget control. But we'd first want to expose the Read/WriteProperties events via a public Export/Import subroutine:
Code:

Public Sub Export(PropBag As PropertyBag)
    If PropBag Is Nothing Then Set PropBag = New PropertyBag
    ' save all class settings to the property bag, exactly same as a usercontrol's WriteProperties event
End Sub
Public Sub Import(PropBag As PropertyBag)
  ' create any classes/references needed for this object (code usually found in the UserControl_Initialize event)
    If PropBag Is Nothing Then
        ' reset all properties to default, exactly same as a usercontrol's InitProperties event
    Else
        ' read all class settings from the property bag, exactly same as a usercontrol's ReadProperties event
    End If
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call Me.Export(PropBag) ' redirect so we don't need double the code
End Sub
Private Sub UserControl_InitProperties()
    Call Me.Import(Nothing) ' redirect so we don't need double the code
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Call Me.Import(PropBag) ' redirect so we don't need double the code
End Sub

[VB6] Lob.com Address Verification

$
0
0
There are all kinds of web services out there. Most have abandoned the troublesome SOAP, but the REST-like API world remains a little bit of a "wild west" and each one may require different fiddling.

Lob.com

This company has a core mission they tag as "Programmatically send physical mail at scale." See Lob.com Inc.

However they do offer one service you might find useful: Easily verify domestic and international mailing addresses.

Quote:

Validate & correct customer addresses

Using Lob's address verification API, you can instantly validate and standardize mailing addresses to help ensure your mail reaches your customers. The API attempts to correct any missing information with data directly from the USPS.

Free. How's that for a price?

Reaching your customers by mail can be a crucial part of your business. That's why the Lob address verification API is free for all addresses within the United States. International mail addresses cost $0.15 per verification.

Free?

Well, free for U.S. addresses.

How long this remains free, or what volume might trigger them to ask you to pay I can't say. As always "modern web sites" can be frustrating wumpus hunts because they tend to be driven by marketing types and built by liberal arts students with secretarial level technical skills and no knack for organization or taste. The good news is that they probably aren't really as juiced up on meth as their output might make you think.

So you may have to make a fresh pot of coffee, put on your "lawyer hat," and go spelunking for an hour or so to satisfy yourself and compile a set of page links and text to pass on to your company's legal team for analysis. But it really does seem free as far as I can determine.


Requirements

To use this particular service from a VB6 program you need a couple of things:

  • The ability to make HTTPS POST requests.
  • The ability to encode your inputs in application/x-www-form-urlencoded format.
  • The ability to parse and use JSON responses.


The demo uses WinHttp for the first bullet, and provides code for the other two.

You need VB6 of course. Then you need an OS that has WinHttp 5.1, such as Windows Vista or later. If you have Win2K SP3 or WinXP SP1 and have installed the updates that added WinHttp 5.1 to those OSs then that works too. However Microsoft Downloads no longer hosts those updates. If desperate enough you might consider using MSXML.XmlHttpRequest instead. Version 3.0 of MSXML is available all the way back to Windows 95, and should be good enough for this.

You also need an account at Lob.com, but you do not need to associate a payment method with your account if you are just going to use Address Verification. I suspect they are fine with this because they already need the database to support their paid services, so providing this "for free" only imposes minimal costs and serves to drive more buisiness to their paid services. Most people needing Address Verification would be likely enough to benefit from those other services anyway.

So "Thanks Lob.com!"


Testing VerifyAddr.vbp

This is a simple VB6 project. Just unzip the attached archive into a folder.

Then you must apply for an account at Lob.com and get your "Test API Key" which you should put into a test file named Creds.txt which VerifyAddr will open and read the Key from as the first line of text.

As far as I can tell these "Test Keys" are all that are ever used to perform Address Verification unless you apply for what Lob.com calls "reserved pricing."

Name:  sshot.png
Views: 37
Size:  25.2 KB

Test run


Here I put in an address for a street that I know got renamed within the last 20 years or so. Sure enough Lob.com corrected it.

This demo program accepts input fields, makes the request, then it dumps the raw (ok, slightly cooked) JSON text for viewing and also parses the JSON and extracts data elements for viewing.

Obviously a real program would be doing something else such as pulling addresses from a database and updating them with the verified results if successful - and logging problems encountered when not successful so that a human could take action.

Quote:

If there is only a partial match and more information is required (e.g. Apt#, etc), a message string with more information will also be returned.
Attached Images
 
Attached Files

[vb6] Scale + Rotation Routine for Sizing Objects

$
0
0
The two routines shown below can be used by anyone that needs one of the following results:

1. Scale an object to a destination object to include rotation & proportional scaling. Fit rotated bounds to container

2. Scale a destination object based on another object that is rotated. Fit container to rotated bounds

The routines are designed to include rotation in the calculations; though an angle of zero degrees can be passed. The word 'container' can be a bitmap, picturebox, your custom usercontrol, or anything that has dimensions. The word 'bounds' is simply a rectangle associated with some object: image, font, etc.

1. This function will take some unrotated, unscaled bounds and scale them to a target container. Rotation of the bounds is an option along with a few other options. The returned scale would be applied to the passed bounds
Code:

Function ScaleBoundsToContainer(ByVal BoundsWidth As Long, ByVal BoundsHeight As Long, _
                                    ByVal ContainerWidth As Long, ByVal ContainerHeight As Long, _
                                    Optional ByVal Angle As Single = 0!, _
                                    Optional ByVal ScaleForAllAngles As Boolean = False, _
                                    Optional ByVal MaxRatioIsActualSize As Boolean = False, _
                                    Optional ByVal LimitBoundsToContainer As Boolean = True) As Single
                                   
    ' Function returns a proportional scale ratio, relative to the passed bounds and
    '  container dimensions at a single angle or all angles
    ' If function returns zero, an error occurred or invalid parameters passed
    ' Parameters:
    '  BoundsWidth,BoundsHeight are the unrotated, base dimensions to be scaled
    '  ContainerWidth,ContainerHeight are the dimensions to restrict scaling
    '  Angle can be any value, including negative and beyond 360 degrees
    '  ScaleForAllAngles if true will return a scale that allows bounds to be rotated across all 360
    '      degree angles within the container and without the bounds changing size per degree of rotation
    '      If false, the scale returned is for the Angle passed & can change from angle to angle
    '  MaxRatioIsActualSize if true will never allow function to return a scale > 1.0
    '  LimitBoundsToContainer if false will always return a scale of 1.0

    Dim xRatio As Double, yRatio As Double
    Dim sinT As Double, cosT As Double
    Dim cx As Double, cy As Double

    If LimitBoundsToContainer = False Then
        xRatio = 1#
       
    ElseIf (BoundsWidth > 0& And BoundsHeight > 0&) Then    ' sanity checks
        If (ContainerWidth > 0& And ContainerHeight > 0&) Then
       
            On Error GoTo ExitRoutine
            If ScaleForAllAngles Then
                xRatio = Sqr(BoundsWidth * BoundsWidth + BoundsHeight * BoundsHeight)
                yRatio = ContainerHeight / xRatio
                xRatio = ContainerWidth / xRatio
            Else
                xRatio = ContainerWidth / BoundsWidth
                yRatio = ContainerHeight / BoundsHeight
               
                Angle = Abs((Fix(Angle) Mod 180) + (Angle - Fix(Angle)))
                If Angle > 90! Then Angle = 180! - Angle
                ' note: actual angle is not needed for this function. Threshold angles to 0-90
                '  i.e., 45,135,225,315,-45 (multiples of 45) are not same angles, however
                '  their 'shape' is the the same. The shape is what is used for the scaling
                If Angle > 0! Then
                    cx = (4# * Atn(1)) / 180#              ' conversion factor for degree>radian
                    sinT = Sin(Angle * cx): cosT = Cos(Angle * cx)
                   
                    If xRatio > yRatio Then xRatio = yRatio
                    cx = BoundsWidth * xRatio              ' scale bounds to container
                    cy = BoundsHeight * xRatio
                                                            ' get relative scale of container after rotation
                    xRatio = ContainerHeight * ContainerHeight / (cx * sinT + cy * cosT)
                    yRatio = ContainerWidth * ContainerHeight / (cx * cosT + cy * sinT)
                    If xRatio < yRatio Then yRatio = xRatio
                    xRatio = yRatio * ContainerWidth / ContainerHeight
                   
                    xRatio = xRatio / BoundsWidth          ' recalculate scale of bounds to container
                    yRatio = yRatio / BoundsHeight
                End If
            End If
            If xRatio > yRatio Then xRatio = yRatio        ' use lower of two ratios
        End If
    End If
   
    If MaxRatioIsActualSize = True Then                          ' limit/restrict scale to 1:1 ?
        If xRatio > 1# Then xRatio = 1#
    End If
    ScaleBoundsToContainer = xRatio
ExitRoutine:
End Function

Samples: The container is shown as a black rectangle
The 1st row of images passes the ScaleForAllAngles parameter as false. You will see that the image size can change dependent on the angle or rotation. Returned scale is variable
The 2nd row of images passes the ScaleForAllAngles parameter as true. You will see that the image maintains the same size at each angle of rotation. Returned scale is constant
Name:  autofit.jpg
Views: 39
Size:  31.9 KB

2. This function will take some unrotated, scaled bounds and return the dimensions that a container would need to be in order to display the bounds after rotation.
Code:

Function ScaleContainerToBounds(ByVal BoundsWidth As Long, ByVal BoundsHeight As Long, _
                                    ByRef ContainerWidth As Long, ByRef ContainerHeight As Long, _
                                    Optional ByVal Angle As Single = 0!, _
                                    Optional ByVal ScaleForAllAngles As Boolean = False) As Boolean

    ' Function returns minimum size of a container to view unclipped bounds at passed rotation
    ' If function returns False, an error occurred or invalid parameters passed
    ' Parameters:
    '  BoundsWidth,BoundsHeight are the unrotated, source dimensions
    '  ContainerWidth,ContainerHeight are the returned dimensions calculated from passed bounds and angle
    '      if function returns False, these parameters when returned are undefined and should be ignored
    '  Angle can be any value, including negative and beyond 360 degrees
    '  ScaleForAllAngles if true will return dimensions that allows bounds to be rotated across all 360
    '      degree angles within the container without clipping
    '      If false, the dimensions returned is for the Angle passed & can change from angle to angle
   
    If (BoundsWidth < 1& Or BoundsHeight < 1&) Then Exit Function
   
    Dim sinT As Double, cosT As Double
    Dim ctrX As Double, ctrY As Double
    Dim dScaler As Double

    On Error GoTo ExitRoutine
    If ScaleForAllAngles Then
        dScaler = Sqr(BoundsWidth * BoundsWidth + BoundsHeight * BoundsHeight)
        If dScaler - Int(dScaler) > 0.00001 Then dScaler = dScaler + 1#
        ContainerWidth = Int(dScaler)
        ContainerHeight = ContainerWidth
    Else
   
        Angle = Abs((Fix(Angle) Mod 180) + (Angle - Fix(Angle)))
        If Angle > 90! Then Angle = 180! - Angle
        ' note: actual angle is not needed for this function. Threshold angles to 0-90
        '  i.e., 45,135,225,315,-45 (multiples of 45) are not same angles, however
        '  their 'shape' is the the same. The shape is what is used for the scaling
        If Angle = 0! Then
            ContainerHeight = BoundsHeight
            ContainerWidth = BoundsWidth
        Else
            dScaler = (4# * Atn(1)) / 180#  ' conversion factor for degree>radian
            sinT = Sin(Angle * dScaler): cosT = Cos(Angle * dScaler)
            ctrX = BoundsWidth / 2#: ctrY = BoundsHeight / 2#
       
            dScaler = (-ctrX * sinT) + (-ctrY * cosT)
            dScaler = (BoundsWidth - ctrX) * sinT + (BoundsHeight - ctrY) * cosT - dScaler
            If dScaler - Int(dScaler) > 0.00001 Then dScaler = dScaler + 1#
            ContainerHeight = Int(dScaler)
           
            dScaler = ((-ctrX * cosT) - (BoundsHeight - ctrY) * sinT)
            dScaler = (BoundsWidth - ctrX) * cosT - (-ctrY * sinT) - dScaler
            If dScaler - Int(dScaler) > 0.00001 Then dScaler = dScaler + 1#
            ContainerWidth = Int(dScaler)
        End If
    End If
    ScaleContainerToBounds = True
ExitRoutine:
End Function

Samples: The container is shown as a black rectangle
The 1st row of images passes the ScaleForAllAngles parameter as false. You will see that the container size can change dependent on the angle or rotation. The container is fitted to the bounds, after rotation. Returned dimensions are variable
The 2nd row of images passes the ScaleForAllAngles parameter as true. You will see that the container size is constant at each angle of rotation. Returned dimensions are constant.
Name:  autosize.jpg
Views: 36
Size:  29.9 KB
Attached Images
  

VB6 - Storing Passwords

$
0
0
I finally found a good use for the background manipulation that VB performs on strings. Normally, a password would be saved in the registry as an encrypted or hashed value in Binary format. The available registry commands in VB only support string values, so saving binary values involves using API calls. Since the VB commands are much simpler, I decided to do a little experimentation. When a byte array is passed to the "SaveSetting" command, it stores the array as if it was a Unicode string. For example, the string "01234" is "00 30 00 31 00 32 00 33 00 34" in memory. When the byte array for this value is stored in the registry with VB, it displays as "??4". This does not take the place of encryption or hashing, as it is easy enough to decode the recovered string, but it does hide the existence of the password store. I have used rather obvious key names in the following, so to hide them you would use less obvious names.
Code:

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)


Private Sub cmdDecode_Click()
    Dim sKey As String
    Dim bBuffer() As Byte
    Dim M%, N%
    sKey = GetSetting("TEST", "Passwords", "Program1")
    ReDim bBuffer(LenB(sKey) - 1)
    CopyMemory bBuffer(0), ByVal StrPtr(sKey), LenB(sKey)
    sKey = String$(UBound(bBuffer) + 1, " ")
    M% = 1
    For N% = 0 To UBound(bBuffer)
        If bBuffer(N%) > 0 Then
            Mid$(sKey, M%, 1) = Chr$(bBuffer(N%))
        End If
        M% = M% + 1
    Next N%
    txtPW.Text = sKey
End Sub

Private Sub cmdGet_Click()
    Dim sKey As String
    Dim bBuffer() As Byte
    Dim M%, N%
    sKey = GetSetting("TEST", "Passwords", "Program1")
    txtPW.Text = sKey
End Sub

Private Sub cmdSave_Click()
    Dim sPW As String
    Dim bTmp() As Byte
    Dim N%
    sPW = txtPW.Text
    ReDim bTmp(Len(sPW) - 1)
    For N% = 1 To Len(sPW)
        bTmp(N% - 1) = Asc(Mid$(sPW, N%, 1))
    Next N%
    SaveSetting "TEST", "Passwords", "Program1", bTmp
End Sub

In the past, if the stored password was empty or non-existent, I would ask the user to enter the password as if they were setting up the program for the first time. If the user forgot the password, he/she could go into the registry, delete the stored password, and enter a new one in the program. This was convenient for the user, but it also made it easy for an unauthorized individual to gain access. What I do now is store a default password. Then when the program is activated, it detects the default password and asks the user to enter a new password. The unreadable storage provided by the above makes duplicating the default password difficult.

J.A. Coutts

Note: I have not tested these routines with real Unicode characters.

Caution: If you encrypt or hash the password, DO NOT convert it back to a string using the above code. Errors will be introduced when the Encrypt/Hash characters &H80 to &H9F are used.

Here's a simple function for calculating the GCD of any 2 positive integers.

$
0
0
This can be useful component of a number of other algorithms.

Code:

Private Function GetGCD(ByVal a As Long, ByVal b As Long) As Long
Dim r As Long
Dim q As Long

' Make sure that a >= b, by XOR swapping a and b if b>a.
If a < b Then
    a = a Xor b
    b = a Xor b
    a = a Xor b
End If

' Use Euclidean algorithm to calculate GCD.
Do
    q = a \ b
    r = a Mod b
    a = b
    b = r
Loop Until r = 0

GetGCD = a
End Function

Simple method for checking primality of number

$
0
0
This checks every positive integer between 2 and the Floor of the Squareroot of the number to be checked, to see if the Mod = 0. If it equals zero, then it is not prime. If it never is zero, then it is prime.

Code:

Private Function IsPrime(ByVal Value As Long) As Boolean
Dim Sqrt As Long
Dim n As Long

If Value < 2 Then Exit Function

Sqrt = Int(Sqr(Value))
For n = 2 To Sqrt
    If Value Mod n = 0 Then Exit For
Next n

If n = Sqrt + 1 Then IsPrime = True
End Function



On a related note, I made this below program that generates prime numbers from 2 to 10,000,000 (not including 10,000,000 as it is not prime). The way it works is this. At each number "n" it checks every previously detected prime number which has an index "i" (in the array the detected primes are stored in) between 2 and the Floor of the Squareroot of "n". It does this check via the Mod operator, and if the Mod is ever found to be 0 (zero) then that number is not prime and it immediately moves to the next number to be checked. It has a prime number checker in it similar to the prime checker above, but unlike the above program, the below one actually generates a list of prime numbers so it only needs to check the current number against the list of previously generated ones. The above prime number checker doesn't generate anything, so the number being checked needs to be checked against every number between 2 and the Floor of the Squareroot of the number being checked. The above PN checker is therefore less optimized in terms of the number of operations needed to check the primality of a given number, but unlike the below code, it doesn't have the burden of saving every found prime number. However the below code is a dedicated prime number generator so it can use the fact that it's generating prime numbers as a way of optimizing the checking of any future numbers for primality. The array of prime numbers it generates is saved to a text file.

Code:

Dim Primes() As Long



Private Sub Form_Load()
Dim n As Long
Dim i As Long
Dim NotPrime As Boolean
Dim Prime As Long
Dim Sqrt As Long

ReDim Primes(0)
Primes(0) = 2

For n = 3 To 10000000
    Sqrt = Int(Sqr(n))
    NotPrime = False
    For i = 0 To UBound(Primes)
        Prime = Primes(i)
        If Prime > Sqrt Then Exit For
        If n Mod Prime = 0 Then
            NotPrime = True
            Exit For
        End If
    Next i
    If NotPrime = False Then Push n
Next n

Open App.Path & "\primes.txt" For Output As #1
For i = 0 To UBound(Primes)
    Print #1, CStr(Primes(i))
Next i
Close #1
End Sub



Private Sub Push(ByVal Value As Long)
ReDim Preserve Primes(UBound(Primes) + 1)
Primes(UBound(Primes)) = Value
End Sub

Binary Code Thunk Experiment

$
0
0
Here's the VB6 code for Form1
Code:

Private Declare Function CallProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal ProcAddr As Long, ByVal Param1 As Long, ByVal Param2 As Long, ByVal Param3 As Long, ByVal Param4 As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Const ThunkStrConst As String = "55 89 E5 8B 45 08 03 45 0C 03 45 10 03 45 14 C9 C2 10 00"
Dim VM As New clsVirtualMemory
Dim MemAddr As Long
Dim ThunkRetVal As Long



Private Sub Form_Load()
Main
End Sub



Private Sub Main()
AllocateMem
CheckAllocation
CopyMem
ExecuteMem
DeallocateMem
PrintRetVal
End Sub



Private Sub AllocateMem()
MemAddr = VM.Allocate(&H10000000, &H1000, True)
End Sub



Private Sub CheckAllocation()
If MemAddr = 0 Then End
If MemAddr <> &H10000000 Then
    DeallocateMem
    End
End If
End Sub



Private Sub CopyMem()
Dim ThunkStr As String
Dim Thunk() As Byte
Dim n As Long

ThunkStr = Replace(ThunkStrConst, " ", "")
ReDim Thunk(Len(ThunkStr) \ 2 - 1)

For n = 0 To UBound(Thunk)
    Thunk(n) = "&h" & Mid$(ThunkStr, n * 2 + 1, 2)
Next n

CopyMemory ByVal MemAddr, Thunk(0), UBound(Thunk) + 1
End Sub



Private Sub ExecuteMem()
ThunkRetVal = CallProc(MemAddr, 1, 2, 3, 4)
End Sub



Private Sub PrintRetVal()
Print ThunkRetVal
End Sub



Private Sub DeallocateMem()
VM.Free
End Sub



Private Sub Form_Unload(Cancel As Integer)
DeallocateMem
End Sub



Here's the code for the class module.
Code:

Private Declare Function VirtualAlloc Lib "kernel32.dll" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32.dll" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function VirtualQuery Lib "kernel32.dll" (ByVal lpAddress As Long, ByRef lpBuffer As MEMORY_BASIC_INFORMATION, ByVal dwLength As Long) As Long
Private Type MEMORY_BASIC_INFORMATION
    BaseAddress As Long
    AllocationBase As Long
    AllocationProtect As Long
    RegionSize As Long
    State As Long
    Protect As Long
    lType As Long
End Type



Dim MemAddr As Long
Dim MemSize As Long
Dim MemExec As Boolean



Public Property Get Address() As Long
Address = MemAddr
End Property

Public Property Get Size() As Long
Size = MemSize
End Property

Public Property Get IsExecutable() As Boolean
IsExecutable = MemExec
End Property



Public Function Allocate(ByVal DesiredAddress As Long, ByVal DesiredSize As Long, Optional ByVal MakeExecutable As Boolean) As Long
Dim AccessType As Long
Dim MemInfo As MEMORY_BASIC_INFORMATION

If MemAddr <> 0 Then Exit Function
If MakeExecutable Then AccessType = &H40 Else AccessType = 4
Allocate = VirtualAlloc(DesiredAddress, DesiredSize, &H3000, AccessType)
If Allocate = 0 Then Exit Function
MemAddr = Allocate
If VirtualQuery(MemAddr, MemInfo, Len(MemInfo)) = 0 Then
    Free
    Allocate = 0
    Exit Function
End If
MemSize = MemInfo.RegionSize
MemExec = MakeExecutable
End Function



Public Function Free() As Long
If MemAddr = 0 Then Exit Function
Free = VirtualFree(MemAddr, 0, &H8000&)
If Free = 0 Then Exit Function
MemAddr = 0
MemSize = 0
End Function



Note that Form1's AutoRedraw property should be set to True for this project, so that the text that is Printed to the form before the form is shown won't be gone when it is shown. Note also that this project may or may not work if run from the VB6 IDE. It depends on if a 4096 byte block of memory starting at virtual memory address 0x10000000 is available when the allocation attempt occurs, or whether that memory happens to be being used by the VB6 IDE at the time. It has ALWAYS worked when running the compiled EXE file. Note that I'm assuming it's being compiled in Native (not P-Code) mode when making that statement, as that's how I've tested it.


Some interesting things you may notice include that the only thing in Form1's Load event is a call to a sub called Main. This is because I wanted to be able to easily debug the EXE file in an external debugger (OllyDbg 2.01 in my case), and there's quite a bit of overhead in terms of the amount of machine-code present in the Load event, but not so much with a sub. So I didn't "pollute" the already crowded Load event with even more code. This makes looking at the code in a debugger much easier. You'll also note that the Main sub simply contains a series of calls to other subs, and that the actual work is divided up into these other subs. The reason for this is so that if you want to only debug certain portions of the code, it's easy to look through the short list of calls, as these calls to other subs are commands that have very little overhead (compared to something like even a simple VB command like a Print statement, which has a TON of overhead in machine-code). Again, this makes looking at it in a debugger much easier.

I'll quickly describe here what each of these subs do:

AllocateMem allocates an executable block of virtual memory, via the Allocate function in an instance of the class module clsVirtualMemory.

CheckAllocation verifies that the memory allocation was successful, and that it successfully put it in the allocated it in the requested location. There's no guaranty that if it is successful, that it will actually be put where you want it. If a given location is already in use, it may do one of 2 things. It may fail, but not necessarily. Alternatively it may succeed but instead of putting it where you wanted it, it may put it somewhere else nearby, and return the corresponding memory address (not good for my thunk, which if it used more advanced code than it currently does, it could fail if not located at the expected address). If the location is not where it is expected, or if the allocation failed altogether, the program is immediately terminated (though if the allocation didn't fail but was at the wrong address, it deallocates the memory just before terminating the program).

CopyMem converts the hex string for the thunk into raw data, and copies it to the allocated executable memory block.

ExecuteMem uses the function CallProc (which aliases to the actual API function CallWindowProcA) to start execution of the thunk code, as well as providing it with 4 parameters. The thunk code in this very simple case just adds the 4 numbers together and returns the sum.

DeallocateMem deallocates the virtual memory block via the Free function in the instance of the clsVirtualMemory class module.

PrintRetVal prints the value returned by the thunk code to the form.



If this program is working properly on your computer, when your form appears you should see the number 10 printed on it.

[VB6] Get extended details about Explorer windows by getting their IFolderView

$
0
0

IShellWindows / IFolderView

There's some basic ways of working with open Explorer windows, but if you really want to do some intensive work with them, the IShellWindows interface lets you get a variety of other interfaces that allow you to get very detailed information about open windows and their items, as well as set view and selection options. You can get a direct line on the IShellBrowser, IShellView, IFolderView, and IShellFolder/IShellItem interfaces for all open folders using this method.
For the purposes of this demonstration, all we're doing is listing some details, but if you're not familiar with those interfaces already just look through their members in Object Browser to see all the other things you can get and set.

Requirements
-Sample project requires Vista+. Some info is retrieved with IFolderView2... but if you just stuck to what is available with IFolderView, you could use this in XP too.
-oleexp 3.4 or higher (released with this sample on 10 Jan 2016) - must add as reference if marked as missing


Technique
The IShellWindows interface conveniently has a default implementation coclass (ShellWindows), so setting up the window enumeration is straightforward. The sample shows 2 different ways to loop through the open windows:
Code:

Set oSW = New ShellWindows
If oSW.Count < 1 Then Exit Sub
ReDim sSelected(oSW.Count - 1)
'METHOD 1: .Item/.Count
'For q = 0 To oSW.Count - 1
'    Set pdp = oSW.Item(CVar(q))
'    Set punkitem = pdp
'---------------

'METHOD 2: IEnumVARIANT
Set spunkenum = oSW.NewEnum
Set spev = spunkenum
Do While spev.Next(1&, pVar, pclt) = NOERROR
    Set punkitem = pVar
'---------------

Interestingly, the pVar here (declared As Variant) actually can be cast by VB into a variable declared As IUnknown just with Set. I had thought it would have been much harder and involve getting the pointer and setting the object through API.

Now that we've got a Variant representing a window, first we get the IShellBrowser interface for it. After that we're golden... we can get the IShellView through .QueryActiveShellView, and then IShellView also implements IFolderView/IFolderView2, so all we need is the Set keyword (this internally calls QueryInterface that you see in the C++ examples of this). Then IFolderView has .GetFolder which can get the IShellItem or IShellFolder of the folder.
(critical error checking and debug logging code omitted, see full sample)
Code:

            IUnknown_QueryService ObjPtr(punkitem), SID_STopLevelBrowser, IID_IShellBrowser, spsb 'get IShellBrowser
                spsb.QueryActiveShellView spsv 'get IShellView
                    Set spfv = spsv 'get IFolderView2
                    spfv.GetFolder IID_IShellItem, lsiptr 'this is original olelib's problem having it as a long, which now needs:
                    If lsiptr Then vbaObjSetAddRef spsi, lsiptr 'get IShellItem

And now we've got everything needed for advanced, detailed interaction with the open Explorer window and its contents.

---------------------------------------
Here's the full EnumWindows routine that fills the ListView in the sample (and the sSelection module-level holder of the contents) and some other supporters. Don't be scared of all the variables!
Code:

Private Sub EnumWindows()
Dim li As ListItem
Dim i As Long, j As Long
Dim s1 As String, s2 As String, s3 As String
Dim lp1 As Long, lp2 As Long, lp3 As Long, lp4 As Long, lp5 As Long
Dim siaSel As IShellItemArray
Dim lpText As Long
Dim sText As String
Dim sItems() As String
Dim punkitem As oleexp3.IUnknown
Dim lPtr As Long
Dim pclt As Long
Dim spsb As IShellBrowser
Dim spsv As IShellView
Dim spfv As IFolderView2
Dim spsi As IShellItem
Dim lpPath As Long
Dim sPath As String
Dim lsiptr As Long
Dim ct As Long
Dim oSW As ShellWindows
Dim spev As oleexp3.IEnumVARIANT
Dim spunkenum As oleexp3.IUnknown
Dim pVar As Variant
Dim pdp As oleexp3.IDispatch
Dim q As Long
Dim tSC(10) As SORTCOLUMN
Set oSW = New ShellWindows
If oSW.Count < 1 Then Exit Sub
ReDim sSelected(oSW.Count - 1)
'METHOD 1: .Item/.Count
'For q = 0 To oSW.Count - 1
'    Set pdp = oSW.Item(CVar(q))
'    Set punkitem = pdp
'---------------

'METHOD 2: IEnumVARIANT
Set spunkenum = oSW.NewEnum
Set spev = spunkenum
Do While spev.Next(1&, pVar, pclt) = NOERROR
    Set punkitem = pVar
'---------------
    ct = ct + 1
    Debug.Print "in loop " & ct
    If True Then
        If (punkitem Is Nothing) = False Then
            Debug.Print "queryservice"
            IUnknown_QueryService ObjPtr(punkitem), SID_STopLevelBrowser, IID_IShellBrowser, spsb
            If (spsb Is Nothing) = False Then
                Debug.Print "queryview"
                spsb.QueryActiveShellView spsv
                If (spsv Is Nothing) = False Then
                    Set spfv = spsv
                    Debug.Print "getfolder"
                    spfv.GetFolder IID_IShellItem, lsiptr ' spsi
                    If lsiptr Then vbaObjSetAddRef spsi, lsiptr
                    If (spsi Is Nothing) = False Then
                   
                        'we've got all relevant interfaces, start adding data
                        spsi.GetDisplayName SIGDN_NORMALDISPLAY, lpPath
                        sPath = LPWSTRtoStr(lpPath)
                        Debug.Print "Open path " & sPath
                        Set li = ListView1.ListItems.Add(, , sPath)
                        spfv.ItemCount SVGIO_ALLVIEW, lp1
                        spfv.ItemCount SVGIO_SELECTION, lp2
                        spfv.GetSortColumnCount lp3
                        If lp3 > 11 Then lp3 = 11
                        spfv.GetSortColumns tSC(0), lp3
                        For j = 0 To lp3
                            If PSGetNameFromPropertyKey(tSC(j).PropKey, lpText) = S_OK Then
                                sText = sText & LPWSTRtoStr(lpText) & "(" & tSC(j).direction & ") "
                            Else
                                Debug.Print "sortcol name needs psstringfrompropertykey; not implemented in this sample"
                            End If
                        Next
                        spfv.GetViewModeAndIconSize lp4, lp5
                        With li
                            .SubItems(1) = lp1
                            .SubItems(2) = lp2
                            .SubItems(3) = sText
                            .SubItems(4) = ViewModeStr(lp4)
                            spsi.GetDisplayName SIGDN_DESKTOPABSOLUTEPARSING, lpPath
                            sPath = LPWSTRtoStr(lpPath)
                            .SubItems(5) = sPath
                        End With
                        If lp2 > 0& Then
                            spfv.GetSelection 0&, siaSel
                            If (siaSel Is Nothing) = False Then
                                sSelected(ct - 1) = GetNamesFromSIA(siaSel)
                            End If
                        Else
                            sSelected(ct - 1) = "(none)"
                        End If
                    Else
                        Debug.Print "Failed to get IShellItem"
                    End If
                Else
                    Debug.Print "Failed to get IShellView"
                End If
            Else
                Debug.Print "Failed to get IShellBrowser"
            End If
        Else
            Debug.Print "Failed to cast enum lPtr to pUnk"
        End If

    Else
        Debug.Print "in loop but lptr=0"
    End If
Set spsi = Nothing
Set spsv = Nothing
Set spsb = Nothing
lsiptr = 0
lp1 = 0
lp2 = 0
lp3 = 0
lp4 = 0
Erase tSC

'switch to next for method 1
Loop
'Next

End Sub
Private Function GetNamesFromSIA(psia As IShellItemArray, Optional nType As SIGDN = SIGDN_NORMALDISPLAY) As String
Dim pEnum As IEnumShellItems
Dim psi As IShellItem
Dim lp As Long
Dim s1 As String
Dim sOut As String
Dim pcl As Long

psia.EnumItems pEnum
If (pEnum Is Nothing) Then Exit Function

Do While (pEnum.Next(1&, psi, pcl) = NOERROR)
    psi.GetDisplayName nType, lp
    sOut = sOut & LPWSTRtoStr(lp) & ", "
Loop
If Len(sOut) > 2 Then
    sOut = Left$(sOut, Len(sOut) - 2) 'remove trailing comma
End If
GetNamesFromSIA = sOut

End Function

Attached Files

[VB6] - Inline assembler Add-in.

$
0
0
Hello everyone!
There are cases where you need to use the assembly code in your VB6 projects. Usually this is done using a previously-compiled code that is placed into the the memory. Then this code is run using one of millions method. Unfortunately this method has the disadvantages. For instance, you will have to change the procedures of the placement code in the memory If you change the asm-code. In addition it is quite slow process. I've written the Add-in that does these process automatically, also after compilation any processes of the placement of the code in the memory are not performed. Asm-code links to EXE. This add-in supports the asm-code either IDE or the compiled form (native only!).

How does it use?
First you have to install the Add-in (installer available at the end of article). After installing you should run the Add-in from VB6 IDE (Add-Ins -> Add-in Manager -> Inline assembler). It adds the new item to Add-Ins menu. If current project does not use the add-In features yet it will add the new module to project. You should add the prototypes of the functions in this module in order to call them from VB6 code. You can rename this module, place the prototypes of the functions, but you can't place the code to this module. After creating of the module you can run the ASM-editor. There is the combobox with the the functions which you defined in the module. For each function you can override the code using the NASM syntax. However if you don't override code (just leaving it empty) a function won't be overridden (this function is left a typical vb6 function). Each project (if you use this Add-in) is associated the additional file with *.ia extension in the project folder. This file contains the asm-codes for each function that is overridden by user. This add-in works "transparently", i.e. if you disable add-in project will work and compile, only "stub-functions" will work without overrides. *.ia file isn't "vitally essential" for working of the project, i.e. this project will work anyway.
Let's consider working of Add-in with the simple example. For instance, we need to mix the two integers-arrays without overflowing, i.e. if the result of the addition is greater than 32767 it should be left to 32767. Opposite, if the result of the addition is smaller than -32768 it should be left to -32768. For this very well suit MMX-extension. It has the instructions for working with the vector data with the saturation. Ok, let's go! Create new project, open Add-in. It adds the new module, rename this module to modInlineAsm. Now define the prototype of the function:
Code:

Public Function MMXAdd( _
                ByRef dest As Integer, _
                ByRef src As Integer, _
                ByVal count As Long) As Long
End Function

At the first parameter we pass the first element of the array, also this array is result; at the second parameter we pass the first element of the second array; finally, at the third parameter we pass the number of the elements. Note that the size should be a multiple of 8 bytes, because we will use the vector instructions, which work with 8 bytes simultaneously. Now define the procedure that will call this function:
Code:

Private Sub Form_Load()
    Dim src()  As Integer
    Dim dst()  As Integer
    Dim size    As Long
    Dim index  As Long
   
    size = 1024
   
    ReDim src(size - 1)
    ReDim dst(size - 1)
   
    For index = 0 To size - 1
        ' // Fill arrays with sine
        src(index) = Sin(index / 40) * 20000
        dst(index) = Sin(index / 23) * 20000
    Next
   
    ' // Add with saturation
    MMXAdd dst(0), src(0), size
   
    '// Draw result
    AutoRedraw = True
   
    Scale (0, 32767)-(index, -32768)
   
    For index = 0 To size - 1
        If index Then
            Me.Line -(index, dst(index))
        Else
            Me.PSet (index, dst(index))
        End If
    Next
   
End Sub

As you can see here both arrays are filled with sines which have the different period. Further we mix these arrays using MMXAdd function. Eventually the result array is being shown to the screen. Now we should override the MMXAdd function. For this activate the Add-in. The editor window will be opened, and there we select the MMXAdd function and add the following code:
Code:

BITS 32

; Addition of two arrays using saturation
; Size of arrays should be a multiple of 8

push    EBP
mov  EBP, ESP
push    EBX
push    ESI
push    EDI
mov  ESI,DWORD [EBP+0x8]
mov  EDI,DWORD [EBP+0x0C]
mov  ECX,DWORD [EBP+0x10]
shr  ECX,2

test  ECX,ECX
je  EXIT_PROC
emms  ; Initialize MMX

CYCLE:
  movq  MM0,QWORD [EDI]
  movq  MM1,QWORD [ESI]
  paddsw  MM1,MM0
  movq  QWORD [ESI],MM1
  add  ESI,0x8
  add  EDI,0x8
loop  CYCLE

emms

EXIT_PROC:
pop    EDI
pop  ESI
pop  EBX
mov  esp, ebp
pop  ebp

ret  0x0c

It's very simple if you know the instruction set. The main instruction is paddsw that adds two four-dimensional 16 bits integer vectors with sign by single operation. Now save project and run it:
Name:  MMX_test.PNG
Views: 64
Size:  20.7 KB
Nice! As you can see at the screenshot, the two sines are added with the saturation. You can notice the saturation by the peaks.
Okay, now let's try to compile the EXE file and check what is called and what is compiled:

As you can see, the code is already inside EXE, without memory allocation and unnecessary stuff.

How does it work?
Actually everything is very simple. When Add-in is connected the handlers of key events are set: the compilation start event, running code event, close/save project event etc. When you run code in IDE the all asm-codes are being compiled, also the addresses of the overrides function are calculated. Further the code of the original stub-functions is replaced to asm-code. When you call the stub-function it calls the asm-code. When you stop the execution the Add-in restores the original code. When you compile to the native code (or rather before linking) it finds the OBJ-file of the overridable module and replaces the code of the stub functions to asm-code and resaves file. For this functionality i write the COFF parser. Generally it can provides the lot of different features.
This project is very poorly tested, because i don't have enough time, therefore i think it'll contain very many bugs. Considering that the half of the project uses the undocumented features and trick, which perhaps don't work as i know. In this project even isn't syntax highlighting, because i don't have the possibility to finish the my highlighter textbox yet. Still i'm using the simple textbox. If someone have found the bugs write here.
Thanks for attention!

[Removed By Mod]
Attached Images
 

Vb6 - graph32

$
0
0
I was in need of a graphical representation of some data, so I dug up an old program and cleaned up the code. The attached example uses "Graph32.ocx" from Pinnacle. Some people are under the impression that VB6 does not support this ActiveX Control. In fact, this control and several others were included in the VB6 CD, but were not installed by default. They can be found in the directory "\COMMON\TOOLS\VB\CONTROLS". The "readme.txt" file has this to say about "Graph32":
"Graph32.ocx has been updated to work properly in Visual Basic 6.0 and it requires two additional support files: gsw32.exe and gswdll32.dll. You must place the three files together in the \Windows\System directory or the control will not function properly."
\Windows\System is actually \Windows\System32\ on 32 bit systems, and \Windows\Syswow64\ on 64 bit systems. The help file (CTRLREF.HLP) is easily accessible by setting the focus on the "Graph" control and pressing the "F1" key. This may require the upgrading of "winhlp32.exe".

This is a fairly easy control to utilize. In it's simplest form it will use the defaults, which consists of random data.
Code:

Private Sub cmdGet5_Click()
    Graph1.Left = 0
    Graph1.Top = 0
    Graph1.ZOrder 0
    Graph1.Width = Me.ScaleWidth
    Graph1.Height = lblRecords.Top
    Graph1.Visible = True
End Sub

For data, the control uses "1" based arrays containing single precision numbers input as string data. If we imagine the graph data to be a 2 dimensional array, in our example it would be a 3x11 array with the dimensions determined by ".NumSets" & ".NumPoints". The number of items in ".LegendText" should match ".NumSets", and the number of items in ".LabelText" should match ".NumPoints". We have used the "QuickData" function to enter the data, which uses a Tab character to separate Point items and a CrLf to separate Set items. Using this function automatically creates ".NumSets" & ".NumPoints".
Code:

Private Sub cmdGet1_Click()
    Const LABEL_LIST As String = "2005,2006,2007,2008,2009,2010,2011,2012,2013,2014,2015"
    Const LEGEND_LIST As String = "Crude Oil,Gasoline,Natural Gas"
    Const SET1_LIST As String = "10.44,11.36,12.52,16.96,10.65,13.60,16.25,16.10,16.77,15.88,8.33"
    Const SET2_LIST As String = "20.18,22.72,24.56,28.68,21.61,24.47,30.96,32.02,33.16,29.56,21.75"
    Const SET3_LIST As String = "12.52,12.81,12.65,14.44,11.21,10.99,10.69,9.66,10.09,10.79,9.50"
    Dim sLabel() As String
    Dim sLegend() As String
    Dim sQuick As String
    Dim N%
    sLabel = Split(LABEL_LIST, ",")
    sLegend = Split(LEGEND_LIST, ",")
    sQuick = SET1_LIST & vbCrLf & SET2_LIST & vbCrLf & SET3_LIST & vbCrLf
    sQuick = Replace(sQuick, ",", vbTab)
    With Graph1
        .Left = 0
        .Top = 0
        .ZOrder 0
        .GraphType = 6 'Line Graph
        .LeftTitle = "USD per Million BTU"
        .GraphTitle = "ENERGY PRICE"
        .BottomTitle = "Average Annual Price per Million BTU"
        .AutoInc = 0
        .RandomData = 0
        .QuickData = sQuick 'Import Data
        For N% = 1 To .NumPoints 'Set X axis labels and legend text
            .ThisPoint = N%
            If N% <= .NumSets Then .LegendText = sLegend(N% - 1)
            .LabelText = sLabel(N% - 1)
        Next N%
        .Width = frmGraph.ScaleWidth
        .Height = lblRecords.Top
        lblRecords = "Total Records = " & CStr(.NumPoints)
        lblCount = "Total Count = " & CStr(.NumPoints * .NumSets)
        .Visible = True
    End With
End Sub

The graph is maintained as a small invisible control in the upper left corner, and the location parameters of this control are stored whenever the form is sized. When the graph control is clicked, the graph is restored to it's saved condition and made invisible again.

Tested on Vista and Win 8.1.

J.A. Coutts
Attached Images
 
Attached Files

[vbRichClient] TabStrip Control (Firefox-like)

$
0
0
Here is my take on a modern browser-like TabStrip, which incorporates all of the features found in such controls such as animated open and closing of tabs, drag and drop to re-arrange, etc.

The important files in the demo are cwTabStrip.cls and cwTabStripButton.cls which are the 'engine' of the control itself. cTabStrip.cls is just a thin wrapper around these in order to expose the public interface

The TabStrip can be initialised with the following boolean parameters UserCanAddTabs, UserCanCloseTabs, UserCanDragTabs which govern the behaviour of the control and mean that it can (if wanted) be used as just a regular tabstrip that the user cannot change.

And here is the demo:


Name:  ts.jpg
Views: 65
Size:  17.9 KB
Attached Images
 
Attached Files

YFrameowrk - A framework that will shorter development time for data oriented apps

$
0
0
Hello,

I have been using this set of routines (YFramework) for almost 10 years now.

I developed to shorted my development time for business apps that are for data oriented.

There is not rocket science involved here! It is just very simple once you understand the fundamentals.

In the zip file I have also provided a working application to show as to how to use YFramework.

I have used VBRichClinet5's SQLite (as I am its fan) so you will require this framework's DLLs to use it. Just download it from links on this forum.

How it works?
It works by loading and saving data from unbound controls to and from database. For this to work what you have to do when designing your forms (windows) is to name the controls as per the field names whose data you want to load in that particular control. For example if you want to load data from a file named UserName then place a TextBox on the form and name the TextBox as UserName.

There are many other useful functions and procedures in the framework. Please do explore it. Like for example to select the content of TextBox when it gets focus, force typing of number keys only for accepting numeric inputs, easily retrieve value of one particular field by just calling a single function, in the same way easily update value of one single field by calling a single function

All kind of feedback (whether good or bad is welcome).

I want to expand this framework but as it seems to satisfy my development requirements I have not expanded it as much as I should have. Olaf your ideas are welcome here as YFramework is based on VBRichClient5.

Note what I am sharing is not complete as some of the code is dependent on commercial ActiveX Components like Essential Toolkit, TextControl and Xtreme SuitePro.

Hope members of this forum will benefit from YFramework. And enjoy using it as much as I enjoy using it even today.

Thank you,

Yogi Yang

[VB6] Code Snippet: Get file overlay (e.g. shortcut arrow), inc. customs like DropBox

$
0
0
Everyone is familiar with the shortcut arrow-- this is an example of an overlay icon, a status indicator placed on top of another icon. Most existing VB file browser examples handle showing these by checking the attributes to see if it's a link or shared. But there's other icons- several more placed by Windows indicating things like offline files, security locks, permission shields, as well as custom ones- one of the most popular is DropBox. So if you want your app to display these as well, you need to look beyond file attributes to the IShellIconOverlay interface.

Requirements
-Windows XP or higher
-oleexp v3.3 or higher (03 Dec 2015 release or newer)
-oleexp addon mIID.bas added (included in oleexp download)

Usage
The GetOverlayIconIndex returns a 1-based index number, so you should determine a valid choice by checking if >0. Assigning an invalid choice (<1 or >15) may result in the main icon not being rendered at all.
If you're using a control such as a ListView or TreeView and are not already assigning overlays, they're typically added like this:
lvi.StateMask = LVIS_OVERLAYMASK
lvi.State = INDEXTOOVERLAYMASK(overlayindex)

where lvi is an LVITEM and this is followed with LVM_INSERTITEM or LVM_SETITEM. TreeViews are nearly identical. Do not set the overlay if there is none (the valid results mentioned above... do not set the statemask/state if the index is 0 or -1).

The Code
Code:

Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long)
Public Declare Function SHGetDesktopFolder Lib "shell32" (ppshf As IShellFolder) As Long

Public Function GetOverlayIconIndex(sPath As String, sFile As String) As Long
'Returns the overlay index for a file icons (like the shortcut arrow)
Dim iDL As Long
Dim psf As IShellFolder
Dim povr As IShellIconOverlay
Dim pUnk As oleexp3.IUnknown
Dim pcid As Long, pche As Long, lAt As Long

iDL = ILCreateFromPathW(StrPtr(sPath))
If iDL Then
    Set psf = GetIShellFolder(isfDesktop, iDL)
    psf.ParseDisplayName 0&, 0&, StrPtr(sFile), pche, pcid, 0&
    If (psf Is Nothing) = False Then
        Set pUnk = psf
        pUnk.QueryInterface IID_IShellIconOverlay, povr
        If (povr Is Nothing) Then
            Debug.Print "GetOverlayIconIndex failed to get ishelliconoverlay " & sFile
        Else
            If pcid Then
                Dim pio As Long
                On Error Resume Next 'CRITICAL: files with no overlay return -1 AND raise a runtime error
                povr.GetOverlayIndex pcid, VarPtr(pio)
                GetOverlayIconIndex = pio
                On Error GoTo 0
            Else
                Debug.Print sFile & "::GetOverlayIconIndex no child pidl"
            End If
        End If
    Else
        Debug.Print "GetOverlayIconIndex::no IShellFolder"
    End If
    Call CoTaskMemFree(pcid)
    Call CoTaskMemFree(iDL)
Else
    Debug.Print "GetOverlayIconIndex::no pidl"
End If

End Function

'Generic support functions you may already have if working with IShellFolder
Public Function GetIShellFolder(isfParent As IShellFolder, pidlRel As Long) As IShellFolder
  Dim isf As IShellFolder
  On Error GoTo out

  Call isfParent.BindToObject(pidlRel, 0, IID_IShellFolder, isf)

out:
  If Err Or (isf Is Nothing) Then
    Set GetIShellFolder = isfDesktop
  Else
    Set GetIShellFolder = isf
  End If

End Function
Public Function isfDesktop() As IShellFolder
  Static isf As IShellFolder
  If (isf Is Nothing) Then Call SHGetDesktopFolder(isf)
  Set isfDesktop = isf
End Function

Notes
-If a file doesn't have an overlay, the COM interface throws a runtime error (0x80004005 automation error unspecified). The code snippet above uses On Error Resume Next to suppress this, but if you have 'Break On All Errors' enabled, it will come up.

-The overlay index returned includes the standard shortcut and share overlays; you can eliminate code checking for them separately.

-Here's the INDEXTOOVERLAYMASK function mentioned earlier if you need it:
Code:

Public Function INDEXTOOVERLAYMASK(iOverlay As Long) As Long
  '  INDEXTOOVERLAYMASK(i)  ((i) << 8)
  INDEXTOOVERLAYMASK = iOverlay * (2 ^ 8)
End Function

UPDATE- Code updated to free child pidl as well; not freeing it causes memory leakage. Call CoTaskMemFree(pcid)

[vb6] Compressing Multiple Property Values into a Long

$
0
0
A lot of verbiage for a couple of 1-line functions. This posting can be beneficial to usercontrol creators and anyone else that would like to reduce the number of variables that are used primarily for property values that contain ranges.
Code:

Private Sub pvSetProperty(PackedValues As Long, PropMask As Long, NewValue As Long)
    PackedValues = (PackedValues And Not PropMask) Or ((PropMask And -PropMask) * NewValue)
End Sub
Private Function pvGetProperty(PackedValues As Long, PropMask As Long)
    pvGetProperty = (PackedValues And PropMask) \ (PropMask And -PropMask)
End Function

I think we all know that a Long value has 32 bits. Most of us also know that we can compress multiple separate values into a long value to save 'space'. For simplicity, we'll define 'space' as individual property settings including their variable declarations and any action required to persist/save those individual settings.

Let's first review different ways of looking at the 32 bits of a Long value
- 2 words, 1 word = 16 bits, 16 bits * 2 words = 32 bits
- 4 bytes, 1 byte = 8 bits, 8 bits * 4 bytes = 32 bits
- 8 nibbles, 1 nibble = 1/2 a byte = 4 bits, 4 bits * 8 nibbles = 32 bits
A word can hold 65536 different values, 0-65535 inclusively, 2^16 bits = 65536
A byte can hold 256 different values, 0-255 inclusively, 2^8 bits = 256
A nibble can hold 16 different values, 0-15 inclusively, 2^4 bits = 16
Another way to look at a Long is as a hexadecimal: FF FF FF FF. Each F is a nibble, each FF is a byte
(*) For our purposes, we will not be using Words. Since we are discussing saving multiple property settings into one Long value, it is highly unlikely you will have a property setting that will consist of 65K options.

So how many property settings can you jam into one Long value? It depends on how many options each property has and how many bits are needed to cover the range of those options. For example, if you had 32 boolean properties, you could fit all 32 into one Long value since a boolean only needs 1 bit: 0=false, 1=true. How do we determine how many bits are needed for the range of the property? A table is useful for those that hate to do the bit count and bit shifts needed.

Range ... Bits Needed
0-1 ... 1 :: 2^1-1 = 0 to 1, 2 options max, i.e., False or True
0-3 ... 2 :: 2^2-1 = 0 to 3, 4 options max
0-7 ... 3 :: 2^3-1 = 0 to 7, 8 options max
0-15 ... 4 :: 2^4-1 = 0 to 15, 16 options max
0-31 ... 5 :: 2^5-1 = 0 to 31, 32 options max
0-63 ... 6 :: 2^6-1 = 0 to 63, 64 options max
0-127 ... 7 :: 2^7-1 = 0 to 127, 128 options max
0-255 ... 8 :: 2^8-1 = 0 to 255, 256 options max
(*) Caveat. For the functions provided above, the high bit (bit 4 in nibble 8) of the Long can only be used for a boolean value. It must never be part of a property that requires more than 1 bit. Nor must the high bit be part of the mask sent to those functions. This is simply to keep the functions simple vs. dealing with the toggling of the sign bit. For ranged properties, consider a Long as a maximum of 31 available bits. Boolean properties can use the functions posted above, but it is easier to toggle them directly. That is also shown below as the 'tip" at end of posting.

Once you know how many bits are needed, you then need to find a location in the Long to place those bits. Simply put, you need consecutive bits available within the Long. The bits can wrap around from 1 nibble to another nibble. In this example we don't have any properties yet assigned to the Long, so 2 bits will fit into the first nibble, leaving 2 bits left in that nibble. If we had another property that required more than 2 bits, we can use the remaining 2 bits of the 1st nibble and the difference placed in the 2nd nibble. We could start in any nibble, on any bit, as long as consecutive bits are available. Do not include the high bit in any ranged property, only as a boolean value.

Now that you can determine how many bits are needed for each property and can determine which of your properties can fit into the Long, you need a bit mask to be able to locate those bits and shift those bits. The shifting is needed in order to place the bits in the proper location within the Long and also to extract those bits and return them to a value that fits within the range of the property options. Again, not all like the math involved with bit shifting, so we will kinda use some shortcuts.

You have bits counted for a property. What is its mask?
Instead of the steps below, you can copy & paste this into your immediate window instead, just fill in the 3 parameters
Code:

' if bits shift into the high bit, overflow error will occur
' bitPos is where in the nibble the first bit will be stored: 1-4
' nrBits is total number of bits for the value: 1-31
' nibble is the one where start of value is stored: 1-8
' FYI: nibble 8, bit position 4 is: &H80000000
bitPos=1:nrBits=1:nibble=1:? "&H" & Hex(((2^nrBits-1)*2^(bitPos-1))*(16^(nibble-1))) & IIF((nibble-1)*4+nrBits+bitPos-1=16,"&","")

Step 1. Start with a blank mask, hexadecimal, so we are looking at each nibble: &H00000000. Each 0 is a nibble and the first nibble is the far right zero. Updating the mask starts with the zero that matches the the nibble position where the 1st bit of the property will be stored.

Step 2. Calculate the mask for that nibble and replace the zero with the hex code for the mask
Start bit position in nibble, number of bits used for that nibble, mask needed
Bit position 1 :: 1 bit used &H1, 2 bits used &H3, 3 bits used &H7, 4 bits used &HF
Bit position 2 :: 1 bit used &H2, 2 bits used &H6, 3 bits used &HE, just 3 bits remain from position #2
Bit position 3 :: 1 bit used &H4, 2 bits used &HC, just 2 bits remain from position #3
Bit position 4 :: always &H8 since only 1 bit is available at position #4
Name:  Nibble.jpg
Views: 70
Size:  24.4 KB
Example
:: 2 bits needed to store the property and starting on nibble 1, bit position 3
:: Blank mask to start with, targeting nibble #1: &H00000000
:: Get mask for nibble. Starting on bit #3, needing 2 bits, mask is &HC. Update mask: &H0000000C

Step 3. If the bits needed to store the property have not all been placed in the mask, move to the next higher nibble, first bit position and repeat previous step until all bits have been accounted for. Example of wrap-around bits:
:: 6 bits needed to store the property and starting on nibble 5, bit position 4 (final bit in that nibble)
:: Blank mask to start with, targeting nibble #5: &H00000000
:: Get mask for nibble 5. Starting on final bit, so mask is &H8. Update mask: &H00080000
:: Get mask for nibble 6. Starting on 1st bit, all 4 bits needed. Update mask: &H00F80000
:: Get mask for nibble 7. Starting on 1st bit, 1 bit needed. Update mask: &H01F80000

(*) Note. If the mask ends up being first 4 nibbles and bit 4 of nibble 4 is used, you must append an ampersand to the end of mask else VB will treat it as a negative Integer value, i.e., &H8000&

And a quick example. Lets say we have a property that requires 3 bits and starts in nibble #6 at bit position #4. Using the steps above, the mask for the property would be &H3800000. The Long variable that holds the property settings is named: m_Properties
Code:

Public Property Get WidgetStyle() As WidgetStyleEnum
    WidgetValue = pvGetProperty(m_Properties, &H3800000)
End Property
Public Property Let WidgetStyle(Value As WidgetStyleEnum)
    ' validate Value is within the range of WidgetStyleEnum else abort
    pvSetProperty m_Properties, &H3800000, Value
End Property

Tip: For boolean properties, it is easier to change the property directly using XOR than to call the above 1-liners. Those 1-liners can still be called, but you must convert the boolean True to an absolute value, not -1. Using XOR is really simple since you have the mask. Let's say the mask is &H80000000, using bit #4 in nibble #8
Code:

Public Property Get AutoSize() As Boolean
    AutoSize = (m_Properties And &H80000000)
End Property
Public Property Let AutoSize(Value As Boolean)
    If Not Value = Me.AutoSize Then
        m_Properties = m_Properties Xor &H80000000
    End If
End Property

Note: If the high bit of the Long is used for a boolean property, it must be handled like the tip above. The 1-liners are not designed to handle the high bit. They can be modified to handle it via IFs.

Tip: If a boolean property is very often used in your code, it is a good strategy to have it occupy the high bit of the Long variable used to store the properties. Why? You can easily test to see if it is set by testing the sign of the Long variable, i.e., if m_Properties < 0 then the high bit is set. Easier than testing if (m_Properties And &H80000000) is non-zero.
Attached Images
 
Viewing all 1326 articles
Browse latest View live




Latest Images