Advanced procedure hacking

[Merri]

Note: most of these features can be simply replicated with API calls that are about equal in speed. TLB files can perfectly replicate these features and be faster too. These may be interesting if you want to do advanced optimization or if you want to work with string arrays in a more powerful manner.

As such these aren't very useful, but provide some nice insight into internal data structures in VB6. I probably revise this post at a later date with more information.

Feel free to ask questions.

' Advanced.bas
Option Explicit

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Ptr As Long, Value As Long)
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal nSize As Long, Optional lpNumberOfBytesWritten As Long) As Long

Public Function InIDE(Optional IDE) As Boolean
    If IsMissing(IDE) Then Debug.Assert Not InIDE(InIDE) Else IDE = True
End Function

Public Property Get Procedure(ByVal AddressOfDest As Long) As Long
    Procedure = AddressOfDest
End Property

Public Property Let Procedure(ByVal AddressOfDest As Long, ByVal AddressOfSrc As Long)
    Dim JMP As Currency, PID As Long
    ' get process handle
    PID = OpenProcess(&H1F0FFF, 0&, GetCurrentProcessId)
    If PID Then
        If InIDE Then
            ' get correct pointers to procedures in IDE
            GetMem4 AddressOfDest + &H16&, AddressOfDest
            GetMem4 AddressOfSrc + &H16&, AddressOfSrc
        End If
        Debug.Assert App.hInstance
        ' ASM JMP (0xE9) followed by bytes to jump in memory
        JMP = (&HE9& * 0.0001@) + (AddressOfSrc - AddressOfDest - 5@) * 0.0256@
        ' write the JMP over the destination procedure
        WriteProcessMemory PID, ByVal AddressOfDest, JMP, 5
        ' close process handle
        CloseHandle PID
    End If
End Property

' Cast.bas
Option Explicit

Public Sub CurAsLong(ByVal Value As Currency, Low As Long, High As Long)
    Procedure(AddressOf Cast.CurAsLong) = Procedure(AddressOf Cast.z_CurAsLong)
    Cast.CurAsLong Value, Low, High
End Sub

Public Function IntAsLong(ByVal Low As Integer, ByVal High As Integer) As Long
    Procedure(AddressOf Cast.IntAsLong) = Procedure(AddressOf Cast.z_IntAsLong)
    IntAsLong = Cast.IntAsLong(Low, High)
End Function

Public Function LngAsCurrency(ByVal Low As Long, ByVal High As Long) As Currency
    Procedure(AddressOf Cast.LngAsCurrency) = Procedure(AddressOf Cast.z_LngAsCurrency)
    LngAsCurrency = Cast.LngAsCurrency(Low, High)
End Function

Public Sub LngAsInteger(ByVal Value As Long, Low As Integer, High As Integer)
    Procedure(AddressOf Cast.LngAsInteger) = Procedure(AddressOf Cast.z_LngAsInteger)
    Cast.LngAsInteger Value, Low, High
End Sub

Public Function LngAsSingle(ByVal Value As Long) As Single
    Procedure(AddressOf Cast.LngAsSingle) = Procedure(AddressOf Cast.z_LngAsSingle)
    LngAsSingle = Cast.LngAsSingle(Value)
End Function

Public Function SngAsLong(ByVal Value As Single) As Long
    Procedure(AddressOf Cast.SngAsLong) = Procedure(AddressOf Cast.z_SngAsLong)
    SngAsLong = Cast.SngAsLong(Value)
End Function



Public Sub z_CurAsLong(ByVal CurLow As Long, ByVal CurHigh As Long, Low As Long, High As Long)
    Low = CurLow
    High = CurHigh
End Sub

Public Function z_IntAsLong(ByVal Value As Long) As Long
    z_IntAsLong = Value
End Function

Public Function z_LngAsCurrency(ByVal Value As Currency) As Currency
    z_LngAsCurrency = Value
End Function

Public Sub z_LngAsInteger(ByVal CurLow As Integer, ByVal CurHigh As Integer, Low As Integer, High As Integer)
    Low = CurLow
    High = CurHigh
End Sub

Public Function z_LngAsSingle(ByVal Value As Single) As Single
    z_LngAsSingle = Value
End Function

Public Function z_SngAsLong(ByVal Value As Long) As Long
    z_SngAsLong = Value
End Function

' Pointer.bas
Option Explicit

Public Function BytArrPtr(Arr() As Byte) As Long
    Procedure(AddressOf Pointer.BytArrPtr) = Procedure(AddressOf Pointer.z_ArrPtr)
    BytArrPtr = Pointer.BytArrPtr(Arr)
End Function

Public Function GetLong(ByVal Ptr As Long) As Long
    Procedure(AddressOf Pointer.GetLong) = Procedure(AddressOf Pointer.z_GetLong)
    GetLong = Pointer.GetLong(Ptr)
End Function

Public Function IntArrPtr(Arr() As Integer) As Long
    Procedure(AddressOf Pointer.IntArrPtr) = Procedure(AddressOf Pointer.z_ArrPtr)
    IntArrPtr = Pointer.IntArrPtr(Arr)
End Function

Public Sub PutCurrency(ByVal Ptr As Long, ByVal Value As Currency)
    Procedure(AddressOf Pointer.PutCurrency) = Procedure(AddressOf z_PutCurrency)
    Pointer.PutCurrency Ptr, Value
End Sub

Public Sub PutLong(ByVal Ptr As Long, ByVal Value As Long)
    Procedure(AddressOf Pointer.PutLong) = Procedure(AddressOf Pointer.z_PutLong)
    Pointer.PutLong Ptr, Value
End Sub

Public Function StrArrPtr(Arr() As String) As Long
    Procedure(AddressOf Pointer.StrArrPtr) = Procedure(AddressOf Pointer.z_ArrPtr)
    StrArrPtr = Pointer.StrArrPtr(Arr)
End Function



Public Function z_ArrPtr(ByVal Value As Long) As Long
    z_ArrPtr = Value
End Function

Public Function z_GetLong(Ptr As Long) As Long
    z_GetLong = Ptr
End Function

Public Sub z_PutCurrency(Ptr As Currency, ByVal Value As Currency)
    Ptr = Value
End Sub

Public Sub z_PutLong(Ptr As Long, ByVal Value As Long)
    Ptr = Value
End Sub

' SafeArray.bas
Option Explicit

Public Function BytArrAsInteger(Arr() As Byte) As Integer()
    Dim Ptr As Long, UB As Long
    Ptr = Not Not Arr
    Debug.Assert App.hInstance
    If Ptr Then
        UB = UBound(Arr)
        If UB And 1 Then
            PutLong BytArrPtr(Arr), 0
            If GetLong(Ptr) And &H800000 Then PutLong Ptr - 4, vbInteger
            PutLong Ptr + 4, 2
            PutLong Ptr + 16, (UB + 1) \ 2
            PutLong IntArrPtr(BytArrAsInteger), Ptr
        End If
    End If
End Function

Public Function IntArrAsByte(Arr() As Integer) As Byte()
    Dim Ptr As Long, UB As Long
    Ptr = Not Not Arr
    Debug.Assert App.hInstance
    If Ptr Then
        UB = UBound(Arr)
        PutLong IntArrPtr(Arr), 0
        If GetLong(Ptr) And &H800000 Then PutLong Ptr - 4, vbByte
        PutLong Ptr + 4, 1
        PutLong Ptr + 16, (UB + 1) * 2
        PutLong BytArrPtr(IntArrAsByte), Ptr
    End If
End Function

Public Function NewByteArray() As Byte()
    Dim H() As Long ' safe array header for an empty byte array
    ReDim H(0 To 6): H(0) = vbByte: H(1) = &H800001: H(2) = 1
    ' H(1) becomes ArrPtr; H(0) is a negative item telling array datatype
    PutLong Pointer.BytArrPtr(NewByteArray), VarPtr(H(1))
    ' remove items from H array
    PutCurrency (Not Not H) + 12, 0
End Function

Public Function NewStringArray() As String()
    Dim H() As Long ' safe array header for an empty string array
    ReDim H(0 To 6): H(0) = vbString: H(1) = &H1800001: H(2) = 4
    ' H(1) becomes ArrPtr; H(0) is a negative item telling array datatype
    PutLong Pointer.StrArrPtr(NewStringArray), VarPtr(H(1))
    ' remove items from H array
    PutCurrency (Not Not H) + 12, 0
End Function

[Merri]

Reserved for possible future code or first post running out of space.