DispInvokeHook

Module1.bas

Option Explicit

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 tmp As Long
Private proc As LongPtr
Private Declare Sub OutputDebugString Lib "kernel32" Alias "OutputDebugStringW" (ByVal lpOutputString As Long)
Private lngOld As Long

Sub Main()

    'mov eax, 0
    'jmp eax
    Const CODE_T = "000000B890E0FF00"
    Dim Code() As Long
    Dim i As Long

    HookProc = VBA.Int(AddressOf DispInvokeHook)

    ReDim Code(0 To (Len(CODE_T) - 1) \ 8)
    For i = 0 To UBound(Code)
        Code(i) = "&H" & Mid$(CODE_T, 1 + i * 8, 8)
    Next
    
    lngCodeLen = (UBound(Code) + 1) * 4
    pProc = VirtualAlloc(0, lngCodeLen, MEM_RESERVE Or MEM_COMMIT, _
                         PAGE_EXECUTE_READWRITE)
    If pProc = 0 Then Err.Raise 7
    tmp = VirtualAlloc(0, lngCodeLen, MEM_RESERVE Or MEM_COMMIT, _
                         PAGE_EXECUTE_READWRITE)
    If tmp = 0 Then Err.Raise 7
    
    CopyLong ByVal pProc, Code(0), lngCodeLen
    CopyLong ByVal pProc + 1, HookProc

    FlushInstructionCache GetCurrentProcess(), ByVal pProc, lngCodeLen

    proc = GetModuleHandle("vbe7.dll")
    If proc = 0 Then Exit Sub
    'Debug.Print Hex$(proc)
    
    proc = proc + &H152054
    'Debug.Print Hex$(proc)
    
    '退避
    CopyLong ByVal tmp, ByVal proc, lngCodeLen

    
    'Hookスタート
    ForceCopyLong proc, pProc

    Dim buf As String
    buf = "かきくけこ"
    Mid(buf, 3) = "か"
    MsgBox buf
    
    MsgBox Excel.Application.Hwnd
    
    EndHook

    
End Sub


' フック終了
Sub EndHook()

    ForceCopyLong proc, tmp
    VirtualProtect proc, lngCodeLen, lngOld, lngOld
    VirtualFree pProc, 0, MEM_RELEASE
    VirtualFree tmp, 0, MEM_RELEASE

End Sub

Private Function DispInvokeHook(ByVal arg1&, _
                            ByVal dispidMember&, _
                            ByVal arg2&, _
                            ByVal arg3&, _
                            ByVal wFlags%, _
                            ByRef pparams&, _
                            ByRef pvarResult, _
                            ByRef pexcepinfo&, _
                            ByRef puArgErr&) As Long

    'MsgBox Hex$(arg1), Hex$(arg2), Hex$(arg3)
    MsgBox "ｺﾈ━━━━(ﾟдﾟ；)━━━━!!"
    
End Function

Private Function ForceCopyLong(ByVal Address As Long, _
                               ByVal Value As Long) As Boolean
    VirtualProtect Address, lngCodeLen, PAGE_EXECUTE_READWRITE, lngOld
    CopyLong ByVal Address, ByVal Value, lngCodeLen

End Function