GetProcAddressHook2

Module1.bas

Option Explicit

Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
Private Declare Function IsBadWritePtr Lib "kernel32" _
        (ByVal lp As Long, ByVal ucb As Long) As Long
Private Declare Function VirtualProtect Lib "kernel32" _
        (ByVal lpAddress As Long, ByVal dwSize As Long, _
        ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" _
        (ByVal lpAddress As Long, ByVal dwSize As Long, _
        ByVal flAllocationType As Long, _
        ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" _
        (ByVal lpAddress As Long, ByVal dwSize As Long, _
        ByVal dwFreeType As Long) As Long
Const PAGE_EXECUTE_READWRITE = &H40
Const MEM_COMMIT = &H1000
Const MEM_RESERVE = &H2000
Const MEM_RELEASE = &H8000&
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function FlushInstructionCache Lib "kernel32" _
        (ByVal hProcess As Long, lpBaseAddress As Any, _
        ByVal dwSize As Long) As Long
Private Declare Sub CopyLong Lib "kernel32" Alias "RtlMoveMemory" _
        (Destination As Any, Source As Any, _
        Optional ByVal length As Long = 4)
Const S_OK = &H0&
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr

Private lngCodeLen As Long
Private pProc As Long
Private HookProc As Long
Private proc As LongPtr
Private Declare Sub OutputDebugString Lib "kernel32" Alias "OutputDebugStringA" (ByVal lpOutputString As Long)

Private Declare PtrSafe Function SysAllocString Lib "OleAut32" (ByVal psz As LongPtr) As LongPtr

Private tmp As Long
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe _
Function GetProcAddressForCaller Lib "KernelBase.dll" ( _
    ByVal hModule As LongPtr, _
    ByVal lpProcName As Long, _
    ByVal esp As LongPtr _
) As LongPtr

Private Declare PtrSafe Function lstrcmp Lib "kernel32" Alias "lstrcmpA" (ByVal lpString1 As Long, ByVal lpString2 As String) As Long

Private Declare PtrSafe _
Function SHUnicodeToAnsi Lib "Shlwapi.dll" ( _
    ByVal pwszSrc As LongPtr, _
    ByVal pszDst As String, _
    ByVal cchBuf As Long _
) As Long


Sub Main()

    tmp = 0&
    
    Dim i As Long
    HookProc = VBA.Int(AddressOf GetProcAddressHook)

    proc = GetModuleHandle("vbe7.dll")
    If proc = 0 Then Exit Sub

    proc = proc + &H20F36C
    
    '退避
    CopyLong tmp, ByVal proc, 4

    Debug.Print Hex$(tmp)

    'Hookスタート
    ForceCopyLong proc, HookProc

    Dim hDLL&
    hDLL = GetModuleHandle("Kernel32")
    
    Dim func&
    func = GetProcAddress(hDLL, "GetProcAddress")
    Debug.Print Hex$(func)
    
    EndHook
    

    
End Sub


' フック終了
Sub EndHook()

    ForceCopyLong proc, tmp
    
End Sub


Private Function GetProcAddressHook(ByVal hModule As LongPtr, ByVal lpProcName As Long) As LongPtr
    
    Dim ret As LongPtr
    ret = VarPtr(hModule) - 4
    CopyLong ret, ByVal ret

    EndHook

    Dim s$, lngRet&
    s = String$(260, 0)
    lngRet = SHUnicodeToAnsi(StrPtr("GetProcAddress"), s, 260)

    If lstrcmp(lpProcName, s) = 0 Then
        Debug.Print "call_"
    End If

    ret = GetProcAddressForCaller(hModule, lpProcName, ret)
    GetProcAddressHook = ret

End Function
 

Private Function ForceCopyLong(ByVal Address As Long, _
                               ByVal Value As Long) As Boolean
    Dim lngOld As Long
    If IsBadWritePtr(Address, 4) Then
        If VirtualProtect(Address, 4, _
                          PAGE_EXECUTE_READWRITE, lngOld) = 0 Then
            Exit Function
        End If
        CopyLong ByVal Address, Value, 4
        VirtualProtect Address, 4, lngOld, lngOld
    Else
        CopyLong ByVal Address, Value, 4
    End If
    ForceCopyLong = True
End Function

Can anybody explain what this code does ?
Regards.