Attribute VB_Name = "modPatch"
Option Explicit '   ‰¨…  '

' The GetModuleHandle function returns a handle to the specified module if the file has been mapped into the callers address space.
Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lspModuleName As Long) As Long

' The LoadLibrary function maps the specified executable module into the callers address space. Success returns a handle to the module.
Private Declare Function LoadLibraryW Lib "kernel32" (ByVal lspLibFileName As Long) As Long

' The GetProcAddress function returns the address of the specified exported dynamic-link library (DLL) function. The lpProcName parameter points to a
' null-terminated ansi function name, or specifies the function's ordinal value which must be in the low-order word; the high-order word must be zero.
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long

' The FreeLibrary function decrements the reference count of the loaded dynamic-link library (DLL) module. When the reference
' count reaches zero, the module is unmapped from the address space of the calling process and the handle is no longer valid.
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long

' If the calling process has read access to all bytes in the specified memory range, the return value is zero.
Private Declare Function IsBadReadPtr Lib "kernel32" (ByVal lp As Long, ByVal ucb As Long) As Long

' The VirtualAlloc function reserves or commits a region of pages in the virtual address space of the calling process.
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long

' The VirtualProtect function changes the access protection on a region of committed pages in the virtual address space of the calling process.
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long

' The VirtualFree function releases or decommits (or both) a region of pages within the virtual address space of the calling process.
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long

' The GetSystemInfo function returns information about the current system.
Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As VB_SYSTEM_PAGESIZE)

' RtlMoveMemory moves memory either forward or backward, aligned or unaligned, in 4-byte blocks, followed by any remaining bytes. Source + Length can overlap the Destination range.
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal cBytes As Long)

Private Const MEM_COMMIT = &H1000&
Private Const MEM_RELEASE = &H8000&

Private Const PAGE_READWRITE = &H4&
Private Const PAGE_EXECUTE = &H10&

Private Type VB_SYSTEM_PAGESIZE
   unused As Long
   dwPageSize As Long ' Specifies the page size and the granularity of page protection and
   unused2(6) As Long ' commitment. This is the page size used by the VirtualAlloc function.
End Type

Private mPageSize As Long

Public Enum eBase_vft
  vftClass = &H1C&
  vftMDIForm = &H6F8&
  vftForm = &H6F8&
  vftPropertyPage = &H710&
  vftUserControl = &H7A4&
End Enum

Private Type tPages
   lpBase As Long
   lStart As Long
End Type

Private atPages() As tPages
Private ccPages As Long

Private Type tAsmCode
   lnPage As Long
   lpMCode As Long
   lpVftProc As Long
   lpOldProc As Long
   sProcName As String
End Type

Private atPatches() As tAsmCode
Private ccPatches As Long

Private Type tMods
   lCnt As Long
   hLib As Long
   sModule As String
   bLoaded As Boolean
End Type

Private atMods() As tMods
Private ccMods As Long

Public Sub PatchAsm(sProcName As String, ByVal lpVft As Long, ByVal lVft_Proc As Long, sEscStr As String)
   Dim lCodeLen As Long
   ReDim Preserve atPatches(ccPatches) As tAsmCode
  On Error GoTo ErrH
   With atPatches(ccPatches)
      lCodeLen = GetCodeSize(sEscStr)
     .lpMCode = AllocMem(lCodeLen, .lnPage)
      EscStr2Mem .lpMCode, lCodeLen, sEscStr
      VirtualProtect atPages(.lnPage).lpBase, mPageSize, PAGE_EXECUTE, 0&
     .lpVftProc = lpVft + lVft_Proc
      CopyMemory .lpOldProc, ByVal .lpVftProc, 4&
      CopyMemory ByVal .lpVftProc, .lpMCode, 4&
     .sProcName = sProcName & "_" & CStr(lpVft) & "_"
      ccPatches = ccPatches + 1&
ErrH: End With
End Sub

Public Sub TermPatches(ByVal lpVft As Long)
   Dim i As Long
   Do Until i = ccPatches
      If InStr(atPatches(i).sProcName, "_" & CStr(lpVft) & "_") <> 0& Then
        On Error GoTo ErrH
         With atPatches(i)
            CopyMemory ByVal .lpVftProc, .lpOldProc, 4&
           .sProcName = vbNullString
ErrH:    End With
      End If
      i = i + 1&
   Loop
End Sub

Public Sub Patch4(sProcName As String, ByVal lpVft As Long, ByVal lIdx As Long, ByVal lVal As Long)
   Dim i As Long: i = ccPatches
   Do Until i = 0&
      i = i - 1&
      If sProcName & "_" & CStr(lpVft) & "_" = atPatches(i).sProcName Then
        On Error GoTo ErrH
         With atPatches(i)
            VirtualProtect atPages(.lnPage).lpBase, mPageSize, PAGE_READWRITE, 0&
            CopyMemory ByVal .lpMCode + lIdx, lVal, 4&
            VirtualProtect atPages(.lnPage).lpBase, mPageSize, PAGE_EXECUTE, 0&
ErrH:    End With
         Exit Sub
      End If
   Loop
End Sub

Public Function ProcAddress(sModule As String, sProc As String) As Long
   Dim i As Long
   Do Until i = ccMods
      If atMods(i).sModule = sModule Then Exit Do
      i = i + 1&
   Loop
   If i = ccMods Then
      ReDim Preserve atMods(i) As tMods
      With atMods(i)
        .sModule = sModule
        .hLib = GetModuleHandleW(StrPtr(sModule))
         If .hLib = 0& Then
           .hLib = LoadLibraryW(StrPtr(sModule))
           .bLoaded = .hLib <> 0&
         End If
      End With
      ccMods = ccMods + 1&
   End If
   If atMods(i).hLib <> 0& Then
      ProcAddress = GetProcAddress(atMods(i).hLib, sProc)
      atMods(i).lCnt = atMods(i).lCnt + 1&
   Else
      MsgBox "This class requires " & sModule & " to be loaded!"
   End If
End Function

Public Sub UnloadLib(sModule As String, sProc As String)
   Dim i As Long
   Do Until i = ccMods
      If atMods(i).sModule = sModule Then Exit Do
      i = i + 1&
   Loop
   If i < ccMods Then
      atMods(i).lCnt = atMods(i).lCnt - 1&
      If atMods(i).lCnt = 0& Then
         If atMods(i).bLoaded Then FreeLibrary atMods(i).hLib
         atMods(i).sModule = vbNullString
      End If
   End If
End Sub

Public Function ArrayPtr(Arr) As Long
   Dim iDataType As Integer
  On Error GoTo UnInit
   CopyMemory iDataType, Arr, 2&
   If (iDataType And vbArray) = vbArray Then
      CopyMemory ArrayPtr, ByVal VarPtr(Arr) + 8&, 4&
   End If
UnInit:
End Function

Public Function SafeArrayPtr(Arr) As Long
   Const VT_BYREF = &H4000
   Dim iDataType As Integer
  On Error GoTo UnInit
   CopyMemory iDataType, Arr, 2&
   If (iDataType And vbArray) = vbArray Then
      CopyMemory SafeArrayPtr, ByVal VarPtr(Arr) + 8&, 4&
      If (iDataType And VT_BYREF) Then
         CopyMemory SafeArrayPtr, ByVal SafeArrayPtr, 4&
      End If
   End If
UnInit:
End Function

' Returns the address of the last private method in
' the specified object's virtual function table, or
' the last public method if no private methods exist.
' Offset -(1*4) second last private method, -(2*4) etc

Public Function GetLastAddr(ByVal ObjPtr_Me As Long, ByVal Base_vft As eBase_vft) As Long
  Dim Addr As Long                           'Address of method code
  Dim i    As Long                           'Loop ordinal
  Dim j    As Long                           'Loop limit
  Dim bSub As Byte                           'Value we expect to find pointed
  Dim bVal As Byte                           '  at by a vTable method entry
  CopyMemory j, ByVal ObjPtr_Me, 4&          'Get the address of the object's instance
  If zProbe(j + Base_vft, i, bSub) Then      'Probe for method using Paul Caton's zProbe
    j = i + 2048&                            'Set reasonable limit, scan 512 vTable entries
    Do While i < j
      CopyMemory Addr, ByVal i + 4&, 4&      'Get the address stored in next vTable entry
      If IsBadReadPtr(Addr, 1&) Then Exit Do 'Is the address an invalid process read access?
      CopyMemory bVal, ByVal Addr, 1&        'Get the byte pointed to by the vTable entry
      If bVal <> bSub Then Exit Do           'If the byte doesn't match the expected value...
      i = i + 4&                             'Next vTable entry
    Loop
    GetLastAddr = i                          'Store last valid vTable entry
  End If
End Function

' Returns the address of the first public method in the
' specified object's virtual function table, or the first
' private/friend method if no public methods exist.
' Offset +(1*4) second public method, +(2*4) etc

Public Function GetFirstAddr(ByVal ObjPtr_Me As Long, Optional ByVal Base_vft As eBase_vft = vftClass) As Long
  Dim Addr As Long
  Dim bSub As Byte
  CopyMemory Addr, ByVal ObjPtr_Me, 4&       'Get the address of the object's instance
  zProbe Addr + Base_vft, GetFirstAddr, bSub 'Probe first method using Paul Caton's zProbe
End Function

'Probe at the specified start address for a method signature
Private Function zProbe(ByVal nStart As Long, ByRef nMethod As Long, ByRef bSub As Byte) As Boolean
  Dim nAddr   As Long
  Dim nLimit  As Long
  Dim nEntry  As Long
  Dim bVal    As Byte
  nAddr = nStart                             'Start address
  nLimit = nAddr + 32&                       'Probe eight entries
  Do While nAddr < nLimit                    'While we've not reached our probe depth
    CopyMemory nEntry, ByVal nAddr, 4&       'Get the vTable entry
    If nEntry <> 0& Then                     'If not an implemented interface
      CopyMemory bVal, ByVal nEntry, 1&      'Get the value pointed at by the vTable entry
      If bVal = &H33 Or bVal = &HE9 Then     'Check for a pcode or native method signature
        nMethod = nAddr                      'Store the vTable entry
        bSub = bVal                          'Store the found method signature
        zProbe = True                        'Indicate success
        Exit Function                        'Return
      End If
    End If
    nAddr = nAddr + 4&                       'Next vTable entry
  Loop
End Function

' When the process terminates, the system releases the committed pages.

Private Function AllocMem(ByVal nBytes As Long, ByRef nPage As Long) As Long
   Dim i As Long
   If mPageSize = 0& Then mPageSize = GetPageSize
   Do Until i = ccPages
      If atPages(i).lStart + nBytes < mPageSize Then Exit Do
      i = i + 1&
   Loop
   If i = ccPages Then
      ReDim Preserve atPages(i) As tPages
      With atPages(i)
        .lpBase = VirtualAlloc(0&, mPageSize, MEM_COMMIT, PAGE_READWRITE)
         AllocMem = .lpBase
        .lStart = (nBytes + 3&) And -4& 'Long align (pad 0 to 3 bytes)
      End With
      ccPages = ccPages + 1&
   Else
      With atPages(i)
         VirtualProtect .lpBase, mPageSize, PAGE_READWRITE, 0&
         AllocMem = .lpBase + .lStart
        .lStart = (.lStart + nBytes + 3&) And -4&
      End With
   End If
   nPage = i
End Function

Private Function GetPageSize() As Long
   Dim sps As VB_SYSTEM_PAGESIZE
   GetSystemInfo sps
   GetPageSize = sps.dwPageSize - 1&
End Function

Private Function GetCodeSize(sEsc As String) As Long
   Dim i As Long, j As Long, k As Long
   i = Len(sEsc): j = i \ 8&: k = i Mod 8&
   If k <> 0& Then k = k - 1& 'Subtract last meta byte
   GetCodeSize = j * 7& + k
End Function

Private Sub EscStr2Mem(ByVal lpMem As Long, ByVal nBytes As Long, sEsc As String)
   Dim i As Long, j As Long, k As Long
   Dim p As Byte, m As Byte, b As Byte
   j = Len(sEsc): k = 2&: m = Asc(sEsc)
   Do Until i = nBytes
       b = Asc(Mid$(sEsc, i + k, 1&))
       If (m And (2 ^ p)) = 0 Then b = b And 127
       CopyMemory ByVal lpMem + i, b, 1& 'Copy byte to allocated memory
       p = (i + 1) Mod 7
       If p = 0 Then
           k = k + 1&: If i + k > j Then Exit Do
           m = Asc(Mid$(sEsc, i + k, 1&))
       End If
       i = i + 1&
   Loop
End Sub

'                                  ‰¨… ¨    …        …
