代码总是可以无限优化，因为你有无限的想象力 ^_~ ...
对于应用了 XP 样式的窗口, 子类化时在调用系统默认处理时必须通过 CallWindowProc 完成调用, 否则将导致程序崩溃
更新后的 iSubClass
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 n_ThunkCodeAddress As Long '// 接口函数所在的内存地址 20 21 End Type 22 23 Dim LinkProc() As Long 24 Dim PG As ThisClassSet 25 26 Event MsgHook(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long) 27 28 Private Sub GetWindowMessage(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long) 29 '子类化接口过程 30 RaiseEvent MsgHook(Result, cHwnd, Message, wParam, lParam) 31 End Sub 32 33 Private Function GetWndProcAddress(ByVal SinceCount As Long) As Long 34 ' 地址指针 ＝ GetWndProcAddress( 取第 N 个公共函数（属性） =或= 所有公共函数个数 + 第 N 个私有函数的函数地址） 35 Dim mePtr As Long 36 Dim jmpAddress As Long 37 38 mePtr = ObjPtr(Me) 39 CopyMemory jmpAddress, ByVal mePtr, 4 40 CopyMemory jmpAddress, ByVal jmpAddress + (SinceCount - 1) * 4 + &H1C, 4 41 42 If App.LogMode = 0 Then 43 44 ReDim LinkProc(16) As Long 45 LinkProc(0) = &H83EC8B55 46 LinkProc(1) = &H75FFFCC4 47 LinkProc(2) = &H1075FF14 48 LinkProc(3) = &HFF0C75FF 49 LinkProc(4) = &HB90875 50 LinkProc(5) = &HFF000010 51 LinkProc(6) = &H1F883D1 52 LinkProc(7) = &H4D8D1575 53 LinkProc(8) = &H6851FC 54 LinkProc(9) = &HB8000020 55 LinkProc(10) = &H3000 56 LinkProc(11) = &H458BD0FF 57 LinkProc(12) = &H680CEBFC 58 LinkProc(13) = &H4000 59 LinkProc(14) = &H5000B9 60 LinkProc(15) = &HC9D1FF00 61 LinkProc(16) = &H10C2 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 CopyMemory ByVal VarPtr(LinkProc(14)) + 1, GetProcAddress(GetModuleHandle("user32.dll"), "CallWindowProcA"), 4& 68 69 PG.n_ThunkCodeAddress = HeapAlloc(GetProcessHeap, &H8, 68&) 70 CopyMemory ByVal PG.n_ThunkCodeAddress, LinkProc(0), 68& 71 VirtualProtect ByVal PG.n_ThunkCodeAddress, ByVal 68&, ByVal &H40&, PG.s_BlockProtect 72 GetWndProcAddress = PG.n_ThunkCodeAddress 73 74 Else 75 ReDim LinkProc(10) 76 LinkProc(0) = &H83EC8B55 77 LinkProc(1) = &H75FFFCC4 78 LinkProc(2) = &H1075FF14 79 LinkProc(3) = &HFF0C75FF 80 LinkProc(4) = &H458D0875 81 LinkProc(5) = &H6850FC 82 LinkProc(6) = &HB8000010 83 LinkProc(7) = &H2000 84 LinkProc(8) = &H458BD0FF 85 LinkProc(9) = &H10C2C9FC 86 87 CopyMemory ByVal VarPtr(LinkProc(5)) + 3, ObjPtr(Me), 4& 88 LinkProc(7) = jmpAddress 89 VirtualProtect ByVal VarPtr(LinkProc(0)), ByVal 40&, ByVal &H40&, PG.s_BlockProtect 90 GetWndProcAddress = VarPtr(LinkProc(0)) 91 92 End If 93 94 End Function 95 96 Function CallDefaultWindowProc(ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 97 '调用窗口默认处理过程 98 CallDefaultWindowProc = CallWindowProc(PG.s_DefaultWindowProc, ByVal cHwnd&, ByVal Message&, ByVal wParam&, ByVal lParam&) 99 End Function 100 101 Function SetMsgHook(ByVal cHwnd As Long) As Long 102 '设置指定窗口的子类化 103 If PG.s_Hwnd Then Class_Terminate 104 PG.s_Hwnd = cHwnd 105 PG.s_DefaultWindowProc = GetWindowLong(cHwnd, ByVal -4&) 106 SetWindowLong ByVal cHwnd, ByVal -4&, ByVal GetWndProcAddress(4) 107 SetMsgHook = PG.s_DefaultWindowProc 108 End Function 109 110 Sub SetMsgUnHook() 111 '取消窗口子类化 112 SetWindowLong ByVal PG.s_Hwnd&, ByVal -4&, ByVal PG.s_DefaultWindowProc& 113 PG.s_Hwnd = 0 114 End Sub 115 116 Private Sub Class_Terminate() 117 SetMsgUnHook 118 If PG.n_ThunkCodeAddress Then 119 VirtualProtect ByVal PG.n_ThunkCodeAddress, ByVal 64&, ByVal PG.s_BlockProtect, PG.s_BlockProtect 120 HeapFree GetProcessHeap, ByVal 0&, PG.n_ThunkCodeAddress 121 PG.n_ThunkCodeAddress = 0 122 End If 123 End Sub
更新内容, (橙色字体部分)
1 Private Function GetWndProcAddress(ByVal SinceCount As Long) As Long 2 ' 地址指针 ＝ GetWndProcAddress( 取第 N 个公共函数（属性） =或= 所有公共函数个数 + 第 N 个私有函数的函数地址） 3 Dim mePtr As Long 4 Dim jmpAddress As Long 5 6 mePtr = ObjPtr(Me) 7 CopyMemory jmpAddress, ByVal mePtr, 4 8 CopyMemory jmpAddress, ByVal jmpAddress + (SinceCount - 1) * 4 + &H1C, 4 9 10 If App.LogMode = 0 Then 11 12 ReDim LinkProc(16) As Long 13 LinkProc(0) = &H83EC8B55 14 LinkProc(1) = &H75FFFCC4 15 LinkProc(2) = &H1075FF14 16 LinkProc(3) = &HFF0C75FF 17 LinkProc(4) = &HB90875 18 LinkProc(5) = &HFF000010 19 LinkProc(6) = &H1F883D1 20 LinkProc(7) = &H4D8D1575 21 LinkProc(8) = &H6851FC 22 LinkProc(9) = &HB8000020 23 LinkProc(10) = &H3000 24 LinkProc(11) = &H458BD0FF 25 LinkProc(12) = &H680CEBFC 26 LinkProc(13) = &H4000 27 LinkProc(14) = &H5000B9 28 LinkProc(15) = &HC9D1FF00 29 LinkProc(16) = &H10C2 30 31 CopyMemory ByVal VarPtr(LinkProc(4)) + 3, GetProcAddress(GetModuleHandle("vba6.dll"), "EbMode"), 4& 32 CopyMemory ByVal VarPtr(LinkProc(8)) + 3, ObjPtr(Me), 4& 33 LinkProc(10) = jmpAddress 34 LinkProc(13) = PG.s_DefaultWindowProc 35 CopyMemory ByVal VarPtr(LinkProc(14)) + 1, GetProcAddress(GetModuleHandle("user32.dll"), "CallWindowProcA"), 4& 36 37 PG.n_ThunkCodeAddress = HeapAlloc(GetProcessHeap, &H8, 68&) 38 CopyMemory ByVal PG.n_ThunkCodeAddress, LinkProc(0), 68& 39 VirtualProtect ByVal PG.n_ThunkCodeAddress, ByVal 68&, ByVal &H40&, PG.s_BlockProtect 40 GetWndProcAddress = PG.n_ThunkCodeAddress 41 42 Else 43 ReDim LinkProc(10) 44 LinkProc(0) = &H83EC8B55 45 LinkProc(1) = &H75FFFCC4 46 LinkProc(2) = &H1075FF14 47 LinkProc(3) = &HFF0C75FF 48 LinkProc(4) = &H458D0875 49 LinkProc(5) = &H6850FC 50 LinkProc(6) = &HB8000010 51 LinkProc(7) = &H2000 52 LinkProc(8) = &H458BD0FF 53 LinkProc(9) = &H10C2C9FC 54 55 CopyMemory ByVal VarPtr(LinkProc(5)) + 3, ObjPtr(Me), 4& 56 LinkProc(7) = jmpAddress 57 VirtualProtect ByVal VarPtr(LinkProc(0)), ByVal 40&, ByVal &H40&, PG.s_BlockProtect 58 GetWndProcAddress = VarPtr(LinkProc(0)) 59 60 End If 61 62 End Function
对应的汇编代码
1 ;// 在 IDE 调试运行时, GetWndProcAddress 释放以下内嵌汇编代码, 用以实现在调试时不崩溃 2 ComCallBack proc chWnd,cMsg,cwParam,clParam 3 4 LOCAL Result 5 6 push clParam 7 push cwParam 8 push cMsg 9 push cHwnd 10 11 mov ecx,1000h 12 call ecx ;// call vba6.dll::EbMode 13 14 .if eax == 1 15 ;// 调试模式下正常运行 16 lea ecx, Result 17 push ecx ;// result 18 push 2000h ;// objptr(me) 19 mov eax,3000h ;// sub: LinkProc 20 Call eax 21 22 mov eax, Result 23 24 .else 25 ;// 调试模式下非正常运行, 中断 打断 断点 结束 26 27 ; 更新前为: 28 ; mov eax, 4000h 29 ; call eax 30 31 ; 更新后为: 32 push 4000h ;// sub: Deault Window Proc 33 mov ecx, 5000h 34 Call ecx 35 36 .endif 37 38 ret 39 40 ComCallBack endp
