Excel 2013 x64/Win8.1用SetWindowSubclassのサブクラス化VBAコード

Module1.bas

Option Explicit
Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExW" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As LongPtr, ByVal lpsz2 As LongPtr) As LongPtr
Private Declare PtrSafe Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Any, _
        ByVal dwSize As LongLong, _
        ByVal flNewProtect As Long, _
        lpflOldProtect As Long) As Long
Const PAGE_EXECUTE_READ = &H20&
Const PAGE_EXECUTE = &H10
Private Declare PtrSafe Function SetWindowSubclass Lib "C:\Windows\WinSxS\amd64_microsoft.windows.common-controls_6595b64144ccf1df_6.0.9600.16384_none_62475f7becb72503\comctl32.dll" (ByVal hWnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr, ByVal dwRefData As LongPtr) As Long
Private Declare PtrSafe Function RemoveWindowSubclass Lib "C:\Windows\WinSxS\amd64_microsoft.windows.common-controls_6595b64144ccf1df_6.0.9600.16384_none_62475f7becb72503\comctl32.dll" (ByVal hWnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As LongPtr)
Private Declare PtrSafe Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Any, ByVal dwSize As LongPtr, ByVal flAllocationType As Long, ByVal flProtect As Long) As LongPtr
Private Declare PtrSafe Function VirtualFree Lib "kernel32" (ByVal lpAddress As Any, ByVal dwSize As LongPtr, ByVal dwFreeType As Long) As Long
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As LongPtr) As LongPtr
Const MEM_TOP_DOWN = &H100000
Const MEM_RELEASE = &H8000&
Const PAGE_EXECUTE_READWRITE = &H40&
Const MEM_RESERVE = &H2000&
Const MEM_COMMIT = &H1000&
Private vp As LongPtr '実行可能コードへのポインタ
Const n1 = 13^ 'DefSubclassProc
Sub starteHook()
    Const code$ = "480475020AFA8166000000B848C3C03390E0FF0000000000"
    Dim hWnd As LongPtr, WndPtr As LongPtr, funcPtr As LongPtr
    Dim i&, length&
    Dim lnglngCode^()
    vp = 0^  '初期化
    hWnd = Application.hWnd
    hWnd = FindWindowEx(hWnd, 0, StrPtr("XLDESK"), 0)
    hWnd = FindWindowEx(hWnd, 0, StrPtr("EXCEL7"), 0)
    
    ReDim lnglngCode(0 To (Len(code) - 1) \ 16)
    For i = 0 To UBound(lnglngCode)
        lnglngCode(i) = "&H" & Mid$(code, 1 + i * 16, 16)
    Next
    length = (UBound(lnglngCode) + 1) * 8
    '実行可能属性を持った領域を確保。
    vp = VirtualAlloc(0&, length, MEM_RESERVE Or MEM_COMMIT, PAGE_EXECUTE_READWRITE)
    CopyMemory ByVal vp, lnglngCode(0), length
    
 
    funcPtr = GetProcAddress(GetModuleHandle(StrPtr( _
            "C:\Windows\WinSxS\amd64_microsoft.windows.common-controls_6595b64144ccf1df_6.0.9600.16384_none_62475f7becb72503\comctl32.dll")), "DefSubclassProc")
               
    CopyMemory ByVal vp + n1, funcPtr, 8
    Dim lngOld&
    VirtualProtect vp, 8, PAGE_EXECUTE, lngOld
    
    'サブクラス化開始
    SetWindowSubclass hWnd, vp, hWnd, 0
    
End Sub
Sub endHook()
    Dim hWnd As LongPtr
    
    hWnd = Application.hWnd
    
    hWnd = FindWindowEx(hWnd, 0, StrPtr("XLDESK"), 0)
    hWnd = FindWindowEx(hWnd, 0, StrPtr("EXCEL7"), 0)
    
    'サブクラス化終了
    RemoveWindowSubclass hWnd, vp, hWnd
    VirtualFree vp, 0, MEM_RELEASE
End Sub