1 Option Explicit 2 3 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As Long = 4) 4 Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 5 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 6 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long 7 Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long 8 Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long 9 Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long 10 Private Declare Function GetProcessHeap Lib "kernel32" () As Long 11 Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long 12 Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long 13 14 Private Type ThisClassSet 15 16 s_DefaultWindowProc As Long 17 s_Hwnd As Long 18 s_BlockProtect As Long 19 20 n_ThunkCodeAddress As Long 21 22 End Type 23 24 Dim LinkProc() As Long 25 Dim PG As ThisClassSet 26 27 Event MsgHook(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long) 28 29 Private Sub GetWindowMessage(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long) 30 '子类化接口过程 31 RaiseEvent MsgHook(Result, cHwnd, Message, wParam, lParam) 32 End Sub 33 34 Private Function GetWndProcAddress(ByVal SinceCount As Long) As Long 35 ' 地址指针 ＝ GetWndProcAddress( 取第 N 个公共函数（属性） =或= 所有公共函数个数 + 第 N 个私有函数的函数地址） 36 Dim mePtr As Long 37 Dim jmpAddress As Long 38 39 mePtr = ObjPtr(Me) 40 CopyMemory jmpAddress, ByVal mePtr, 4 41 CopyMemory jmpAddress, ByVal jmpAddress + (SinceCount - 1) * 4 + &H1C, 4 42 43 If App.LogMode = 0 Then 44 45 ReDim LinkProc(15) As Long 46 LinkProc(0) = &H83EC8B55 47 LinkProc(1) = &H75FFFCC4 48 LinkProc(2) = &H1075FF14 49 LinkProc(3) = &HFF0C75FF 50 LinkProc(4) = &HB90875 51 LinkProc(5) = &HFF000010 52 LinkProc(6) = &H1F883D1 53 LinkProc(7) = &H4D8D1575 54 LinkProc(8) = &H6851FC 55 LinkProc(9) = &HB8000020 56 LinkProc(10) = &H3000 57 LinkProc(11) = &H458BD0FF 58 LinkProc(12) = &HB807EBFC 59 LinkProc(13) = &H4000 60 LinkProc(14) = &HC2C9D0FF 61 LinkProc(15) = &H10 62 63 CopyMemory ByVal VarPtr(LinkProc(4)) + 3, GetProcAddress(GetModuleHandle("vba6.dll"), "EbMode"), 4& 64 CopyMemory ByVal VarPtr(LinkProc(8)) + 3, ObjPtr(Me), 4& 65 LinkProc(10) = jmpAddress 66 LinkProc(13) = PG.s_DefaultWindowProc 67 68 PG.n_ThunkCodeAddress = HeapAlloc(GetProcessHeap, &H8, 64&) 69 CopyMemory ByVal PG.n_ThunkCodeAddress, LinkProc(0), 64& 70 VirtualProtect ByVal PG.n_ThunkCodeAddress, ByVal 64&, ByVal &H40&, PG.s_BlockProtect 71 GetWndProcAddress = PG.n_ThunkCodeAddress 72 73 Else 74 ReDim LinkProc(10) 75 LinkProc(0) = &H83EC8B55 76 LinkProc(1) = &H75FFFCC4 77 LinkProc(2) = &H1075FF14 78 LinkProc(3) = &HFF0C75FF 79 LinkProc(4) = &H458D0875 80 LinkProc(5) = &H6850FC 81 LinkProc(6) = &HB8000010 82 LinkProc(7) = &H2000 83 LinkProc(8) = &H458BD0FF 84 LinkProc(9) = &H10C2C9FC 85 86 CopyMemory ByVal VarPtr(LinkProc(5)) + 3, ObjPtr(Me), 4& 87 LinkProc(7) = jmpAddress 88 VirtualProtect ByVal VarPtr(LinkProc(0)), ByVal 40&, ByVal &H40&, PG.s_BlockProtect 89 GetWndProcAddress = VarPtr(LinkProc(0)) 90 91 End If 92 93 End Function 94 95 Function CallDefaultWindowProc(ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 96 '调用窗口默认处理过程 97 CallDefaultWindowProc = CallWindowProc(PG.s_DefaultWindowProc, ByVal cHwnd&, ByVal Message&, ByVal wParam&, ByVal lParam&) 98 End Function 99 100 Function SetMsgHook(ByVal cHwnd As Long) As Long 101 '设置指定窗口的子类化 102 PG.s_Hwnd = cHwnd 103 PG.s_DefaultWindowProc = GetWindowLong(cHwnd, ByVal -4&) 104 SetWindowLong ByVal cHwnd, ByVal -4&, ByVal GetWndProcAddress(4) 105 SetMsgHook = PG.s_DefaultWindowProc 106 End Function 107 108 Sub SetMsgUnHook() 109 '取消窗口子类化 110 SetWindowLong ByVal PG.s_Hwnd&, ByVal -4&, ByVal PG.s_DefaultWindowProc& 111 If PG.n_ThunkCodeAddress Then 112 VirtualProtect ByVal PG.n_ThunkCodeAddress, ByVal 64&, ByVal PG.s_BlockProtect, PG.s_BlockProtect 113 HeapFree GetProcessHeap, ByVal 0&, PG.n_ThunkCodeAddress 114 PG.n_ThunkCodeAddress = 0 115 End If 116 End Sub 117 118 Private Sub Class_Terminate() 119 SetMsgUnHook 120 End Sub 121 122 ''// 在编译后, GetWndProcAddress 释放以下内嵌汇编代码, 效率最大化 123 ''ComCallBack1 proc hWnd,Msg,wParam,lParam 124 '' 125 '' LOCAL Result 126 '' 127 '' push lParam 128 '' push wParam 129 '' push Msg 130 '' push hWnd 131 '' 132 '' lea eax, Result 133 '' push eax ;// 134 '' 135 '' push 1000h ;// objptr(me) 136 '' 137 '' mov eax,2000h ;// sub: LinkProc 138 '' Call eax 139 '' 140 '' mov eax,Result ;// Return Value 141 '' 142 '' ret 143 ''ComCallBack1 endp 144 '' 145 ''============================================================================================================================================ 146 '' 147 ''// 在 IDE 调试运行时, GetWndProcAddress 释放以下内嵌汇编代码, 用以实现在调试时不崩溃 148 ''ComCallBack proc hWnd,Msg,wParam,lParam 149 '' 150 '' LOCAL Result 151 '' 152 '' push lParam 153 '' push wParam 154 '' push Msg 155 '' push hWnd 156 '' 157 '' mov ecx,1000h 158 '' call ecx ;// call vba6.dll::EbMode 159 '' 160 '' .if eax == 1 161 '' ;// 调试模式下正常运行 162 '' lea ecx, Result 163 '' push ecx ;// result 164 '' push 2000h ;// objptr(me) 165 '' mov eax,3000h ;// sub: LinkProc 166 '' Call eax 167 '' 168 '' mov eax, Result 169 '' 170 '' .else 171 '' ;// 调试模式下非正常运行, 中断 打断 断点 结束 172 '' mov eax,4000h ;// sub: Deault Window Proc 173 '' Call eax 174 '' 175 '' .endif 176 '' 177 '' ret 178 '' 179 ''ComCallBack endp
相关文章：