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
本来不打算再写新的 iSubClass ， 之前的版本有关 无崩溃 的问题一直没有完美解决
这两天 地雷 ， 不知道突然抽什么疯， 仔细研究了一下泊来的那个不崩溃子类化的类， 发现了 vba6.dll:: EbMode
这个函数能够在 IDE 状态下获取 vb 调试器的状态 Return Value： 0 调试器停止； 1 调试器正常运行； 2 调试器被中断
很强大。。。根据 ws地雷提供的信息， 对之前版本的 iSubClass 稍稍改造了一下， 终于实现了基本稳定，不崩溃的子类化代码，而且兼具强悍效率。
泊来的那个单类子类化代码，又乱，又不高效（同时多开几个实例，程序会很卡），可能唯一的好处就是稳定了
现在这个代码还是有几个小问题：
1. 用 ■ 中断停止， 会有 64 字节的资源泄漏，不过问题不大，且编译后不存在这个问题， 使用者完全可以无视。
2. 遇有错误代码导致的调试中断（暂时状态，非退出调试）时，可能会临时性的引起vb工具栏的冻结，貌似也问题不大，多点几下 ▲ 或者 ■ 就行了
其他问题，暂时还没发现，如有请跟帖告之。。。
本次修改， 对代码接口稍有修改，主要是为了看着顺眼，如果要替换之前已做好的代码，去马子的网站要马子之前拿到的版本。
马子的那份代码可以直接把原来的 iSubClass 删掉， 换新的即可，接口代码一点没变，直接用。
要是用本帖的代码， 可能你需要修改一下， 事件的名字改了一下， 改成了 MsgHook ，内接函数改成了 GetWindowMessage
然后就是优化了一下代码，给马子的版本里面有很多笔误代码没改掉
再放一个演示代码： 无崩溃子类化代码终极版
