代码
1 Option Explicit
2 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As Long = 4)
3 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
4 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
5 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
6 Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
7 Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
8 Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
9 Private Declare Function GetProcessHeap Lib "kernel32" () As Long
10 Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
11 Private Declare Function HeapDestroy Lib "kernel32" (ByVal hHeap As Long) As Long
12
13 Private Type ThisClassSet
14 s_srcWndProcAddress As Long
15 s_Hwnd As Long
16
17 n_heapAlloc As Long
18 End Type
19 Dim LinkProc(29) As Long
20 Dim PG As ThisClassSet
21
22 Event GetWindowMessage(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
23
24 Private Sub MsgHook(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
25 '子类化接口过程
26 RaiseEvent GetWindowMessage(Result, cHwnd, Message, wParam, lParam)
27 End Sub
28
29 Private Function GetWndProcAddress(ByVal OrgWindowProc As Long, ByVal SinceCount As Long) As Long
30 ' 地址指针 ＝ GetWndProcAddress( 取第 N 个公共函数（属性） =或= 所有公共函数个数 + 第 N 个私有函数的函数地址）
31 Dim mePtr As Long
32 Dim jmpAddress As Long
33 Dim i As Long
34 Dim Protlng As Long
35
36 mePtr = ObjPtr(Me)
37 CopyMemory jmpAddress, ByVal mePtr, 4
38 CopyMemory jmpAddress, ByVal jmpAddress + (SinceCount - 1) * 4 + &H1C, 4
39
40
41 LinkProc(0) = &H83EC8B55
42 LinkProc(1) = &H75FFFCC4
43 LinkProc(2) = &H1075FF14
44 LinkProc(3) = &HFF0C75FF
45 LinkProc(4) = &HB80875
46 LinkProc(5) = &HB000040
47 LinkProc(6) = &HB94575C0
48 LinkProc(7) = &H1000&
49 LinkProc(8) = &H830C458B
50 LinkProc(9) = &H87502F8
51 LinkProc(10) = &H1C7&
52 LinkProc(11) = &H1BEB0000
53 LinkProc(12) = &H863D&
54 LinkProc(13) = &H8B077500
55 LinkProc(14) = &H1891045
56 LinkProc(15) = &H5A3D0DEB
57 LinkProc(16) = &H75000010
58 LinkProc(17) = &H101C706
59 LinkProc(18) = &H83000000
60 LinkProc(19) = &H2750139
61 LinkProc(20) = &H680EEB
62 LinkProc(21) = &HB8000020
63 LinkProc(22) = &H3000&
64 LinkProc(23) = &H13EBD0FF
65 LinkProc(24) = &H50FC458D
66 LinkProc(25) = &H500068
67 LinkProc(26) = &H6000B800
68 LinkProc(27) = &HD0FF0000
69 LinkProc(28) = &HC9FC458B
70 LinkProc(29) = &H10C2&
71
72 i = App.LogMode
73 CopyMemory ByVal VarPtr(LinkProc(4)) + 3, i, 4& ' Label Sign: 0400000
74 CopyMemory ByVal VarPtr(LinkProc(25)) + 1, mePtr, 4& ' Label Sign: 0500000
75 CopyMemory ByVal VarPtr(LinkProc(26)) + 2, jmpAddress, 4& ' Label Sign: 0600000
76
77 If i Then
78 i = VarPtr(LinkProc(0))
79 Protlng = 120
80 Else
81 PG.n_heapAlloc = HeapAlloc(GetProcessHeap, &H8, 128&)
82 CopyMemory ByVal PG.n_heapAlloc + 120&, 1&, 4
83 LinkProc(7) = PG.n_heapAlloc + 120 ' Label Sign: 0100000
84 CopyMemory ByVal VarPtr(LinkProc(20)) + 3, OrgWindowProc, 4& ' Label Sign: 0200000
85 LinkProc(22) = GetProcAddress(GetModuleHandle("user32.dll"), "CallWindowProcA") ' Label Sign: 0300000
86
87 CopyMemory ByVal PG.n_heapAlloc&, LinkProc(0), 120&
88 i = PG.n_heapAlloc
89 Protlng = 128
90 End If
91
92 VirtualProtect ByVal i&, Protlng, &H40, mePtr
93 GetWndProcAddress = i
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_srcWndProcAddress, ByVal cHwnd&, ByVal Message&, ByVal wParam&, ByVal lParam&)
99 End Function
100
101 Function SetMsgHook(ByVal cHwnd As Long) As Long
102 '设置指定窗口的子类化
103 PG.s_Hwnd = cHwnd
104 PG.s_srcWndProcAddress = GetWindowLong(cHwnd, ByVal -4&)
105 SetWindowLong ByVal cHwnd, ByVal -4&, ByVal GetWndProcAddress(PG.s_srcWndProcAddress, 4)
106 SetMsgHook = PG.s_srcWndProcAddress
107 End Function
108
109 Sub SetMsgUnHook()
110 '取消窗口子类化
111 SetWindowLong ByVal PG.s_Hwnd&, ByVal -4&, ByVal PG.s_srcWndProcAddress&
112 End Sub
113
114 Private Sub Class_Terminate()
115 ' If PG.n_heapAlloc Then HeapDestroy (PG.n_heapAlloc)
116 ' 还有最后这一点小瑕疵，应该把这个内存释放代码放到内嵌的汇编代码中去释放，懒得弄了，这会有一点的内存浪费
117 End Sub
118
119
120 ''ComCallBack proc hWnd,Msg,wParam,lParam
121 ''
122 '' LOCAL Result
123 '' push lParam
124 '' push wParam
125 '' push Msg
126 '' push hWnd
127 ''
128 '' mov eax,4000h ; 调试模式, app.logmode
129 '' .if !eax
130 '' mov ecx,1000h ; 临时存储区
131 '' mov eax, Msg
132 '' .if eax == WM_DESTROY
133 '' mov dword ptr [ecx],0
134 ''
135 '' .elseif eax==WM_NCACTIVATE
136 '' mov eax, wParam
137 '' mov [ecx], eax
138 '' .elseif eax == 0105ah
139 '' mov dword ptr [ecx],1
140 '' .endif
141 ''
142 '' .if dword ptr [ecx] ==1
143 '' jmp @F
144 '' .endif
145 ''
146 '' push 2000h ; 默认窗口处理函数地址
147 '' mov eax,3000h ; callwindowproc 函数地址
148 '' Call eax
149 ''
150 '' .else
151 '' @@:
152 '' lea eax, Result
153 '' push eax
154 '' push 5000h ; objptr(me)
155 '' mov eax, 6000h ; me.subentry
156 '' Call eax
157 '' mov eax, Result
158 '' .endif
159 ''ExitProc: ret
160 ''
161 ''ComCallBack endp
162
2 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As Long = 4)
3 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
4 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
5 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
6 Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
7 Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
8 Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
9 Private Declare Function GetProcessHeap Lib "kernel32" () As Long
10 Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
11 Private Declare Function HeapDestroy Lib "kernel32" (ByVal hHeap As Long) As Long
12
13 Private Type ThisClassSet
14 s_srcWndProcAddress As Long
15 s_Hwnd As Long
16
17 n_heapAlloc As Long
18 End Type
19 Dim LinkProc(29) As Long
20 Dim PG As ThisClassSet
21
22 Event GetWindowMessage(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
23
24 Private Sub MsgHook(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
25 '子类化接口过程
26 RaiseEvent GetWindowMessage(Result, cHwnd, Message, wParam, lParam)
27 End Sub
28
29 Private Function GetWndProcAddress(ByVal OrgWindowProc As Long, ByVal SinceCount As Long) As Long
30 ' 地址指针 ＝ GetWndProcAddress( 取第 N 个公共函数（属性） =或= 所有公共函数个数 + 第 N 个私有函数的函数地址）
31 Dim mePtr As Long
32 Dim jmpAddress As Long
33 Dim i As Long
34 Dim Protlng As Long
35
36 mePtr = ObjPtr(Me)
37 CopyMemory jmpAddress, ByVal mePtr, 4
38 CopyMemory jmpAddress, ByVal jmpAddress + (SinceCount - 1) * 4 + &H1C, 4
39
40
41 LinkProc(0) = &H83EC8B55
42 LinkProc(1) = &H75FFFCC4
43 LinkProc(2) = &H1075FF14
44 LinkProc(3) = &HFF0C75FF
45 LinkProc(4) = &HB80875
46 LinkProc(5) = &HB000040
47 LinkProc(6) = &HB94575C0
48 LinkProc(7) = &H1000&
49 LinkProc(8) = &H830C458B
50 LinkProc(9) = &H87502F8
51 LinkProc(10) = &H1C7&
52 LinkProc(11) = &H1BEB0000
53 LinkProc(12) = &H863D&
54 LinkProc(13) = &H8B077500
55 LinkProc(14) = &H1891045
56 LinkProc(15) = &H5A3D0DEB
57 LinkProc(16) = &H75000010
58 LinkProc(17) = &H101C706
59 LinkProc(18) = &H83000000
60 LinkProc(19) = &H2750139
61 LinkProc(20) = &H680EEB
62 LinkProc(21) = &HB8000020
63 LinkProc(22) = &H3000&
64 LinkProc(23) = &H13EBD0FF
65 LinkProc(24) = &H50FC458D
66 LinkProc(25) = &H500068
67 LinkProc(26) = &H6000B800
68 LinkProc(27) = &HD0FF0000
69 LinkProc(28) = &HC9FC458B
70 LinkProc(29) = &H10C2&
71
72 i = App.LogMode
73 CopyMemory ByVal VarPtr(LinkProc(4)) + 3, i, 4& ' Label Sign: 0400000
74 CopyMemory ByVal VarPtr(LinkProc(25)) + 1, mePtr, 4& ' Label Sign: 0500000
75 CopyMemory ByVal VarPtr(LinkProc(26)) + 2, jmpAddress, 4& ' Label Sign: 0600000
76
77 If i Then
78 i = VarPtr(LinkProc(0))
79 Protlng = 120
80 Else
81 PG.n_heapAlloc = HeapAlloc(GetProcessHeap, &H8, 128&)
82 CopyMemory ByVal PG.n_heapAlloc + 120&, 1&, 4
83 LinkProc(7) = PG.n_heapAlloc + 120 ' Label Sign: 0100000
84 CopyMemory ByVal VarPtr(LinkProc(20)) + 3, OrgWindowProc, 4& ' Label Sign: 0200000
85 LinkProc(22) = GetProcAddress(GetModuleHandle("user32.dll"), "CallWindowProcA") ' Label Sign: 0300000
86
87 CopyMemory ByVal PG.n_heapAlloc&, LinkProc(0), 120&
88 i = PG.n_heapAlloc
89 Protlng = 128
90 End If
91
92 VirtualProtect ByVal i&, Protlng, &H40, mePtr
93 GetWndProcAddress = i
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_srcWndProcAddress, ByVal cHwnd&, ByVal Message&, ByVal wParam&, ByVal lParam&)
99 End Function
100
101 Function SetMsgHook(ByVal cHwnd As Long) As Long
102 '设置指定窗口的子类化
103 PG.s_Hwnd = cHwnd
104 PG.s_srcWndProcAddress = GetWindowLong(cHwnd, ByVal -4&)
105 SetWindowLong ByVal cHwnd, ByVal -4&, ByVal GetWndProcAddress(PG.s_srcWndProcAddress, 4)
106 SetMsgHook = PG.s_srcWndProcAddress
107 End Function
108
109 Sub SetMsgUnHook()
110 '取消窗口子类化
111 SetWindowLong ByVal PG.s_Hwnd&, ByVal -4&, ByVal PG.s_srcWndProcAddress&
112 End Sub
113
114 Private Sub Class_Terminate()
115 ' If PG.n_heapAlloc Then HeapDestroy (PG.n_heapAlloc)
116 ' 还有最后这一点小瑕疵，应该把这个内存释放代码放到内嵌的汇编代码中去释放，懒得弄了，这会有一点的内存浪费
117 End Sub
118
119
120 ''ComCallBack proc hWnd,Msg,wParam,lParam
121 ''
122 '' LOCAL Result
123 '' push lParam
124 '' push wParam
125 '' push Msg
126 '' push hWnd
127 ''
128 '' mov eax,4000h ; 调试模式, app.logmode
129 '' .if !eax
130 '' mov ecx,1000h ; 临时存储区
131 '' mov eax, Msg
132 '' .if eax == WM_DESTROY
133 '' mov dword ptr [ecx],0
134 ''
135 '' .elseif eax==WM_NCACTIVATE
136 '' mov eax, wParam
137 '' mov [ecx], eax
138 '' .elseif eax == 0105ah
139 '' mov dword ptr [ecx],1
140 '' .endif
141 ''
142 '' .if dword ptr [ecx] ==1
143 '' jmp @F
144 '' .endif
145 ''
146 '' push 2000h ; 默认窗口处理函数地址
147 '' mov eax,3000h ; callwindowproc 函数地址
148 '' Call eax
149 ''
150 '' .else
151 '' @@:
152 '' lea eax, Result
153 '' push eax
154 '' push 5000h ; objptr(me)
155 '' mov eax, 6000h ; me.subentry
156 '' Call eax
157 '' mov eax, Result
158 '' .endif
159 ''ExitProc: ret
160 ''
161 ''ComCallBack endp
162
iSubClass 一向是以精简的代码实现的子类化，但一直存在一个大问题就是无法保证调试的安全性；
IDE崩溃是很烦人的，即便有最最方便的最最精简的效率最高的代码实现了单类模块子类化，用起来也很难受。
此代码在我的系统中实现了无崩溃，即调试运行 》按 ■ 按钮直接停止运行，而不会崩溃。
我还是把代码公布出来了，目的在于共同讨论下，他的实现方法，网上很流行的那个一大堆代码实现的无崩溃子类
他的方法其实不是很好，一点都不自由，而且最要命的是效率问题，多实现几个子类，就会很卡
另外还有一个问题会引起崩溃，暂时也未考虑解决他，当代码中包含错误代，调试时会被IDE自动暂停，此时按■强制停止就会导致崩溃
临时解决办法就是注释错误行，然后继续运行，然后再停止。。。
之所以没有解决他，因为需要对大量消息进行拦截判断状态，这样的话一是太影像效率，再者就是会吃掉太多消息
说下这个无崩溃的实现方法吧：
我先用spy监视了下窗口切换时的消息，最终使用了 WM_NCACTIVATEA 做为标志，和未知消息 &H105A， 再有就是 WM_DESTORY
WM_NCACTIVATE 发生时，直接执行 CallWindowProc 默认过程，并设置了一个状态
&H105A 每次WM_NCACTIVATE 发生，且自己的程序窗口得到焦点或者说是被切换为活动状态时，会有这么一个消息发生
于是，我将这个消息做为关键点，当他发生时，改变WM_NCACTIVATE设置的状态，让他 Call 类中的方法
WM_DESTORY 当发生窗口销毁事件时，代码把之后的所有消息都劫持了，都发送到默认的窗口处理过程去
这样，就相当于没子类化，不过其实也就是浪费了几个消息而已，大多数的应用应该够了
关键点就这些；
另外还有一点就是，关于内嵌汇编所占用的128字节空间，不能保存在数组中了，必须单独开辟一个类销毁时，数据不被销毁的内存区域
这样才能实现不崩溃，但不好的地方在于这128字节的空间，没机会销毁了，我打算接下来这样修改，在 WM_NCDESTORY 消息中，销毁这个内存
目前还不敢肯定能成功，这个销毁其实只是内存不在占用的一个标记，数据部分并没有真正销毁，总之之后再说。。。
下面有测试代码，请大家试试，然后回复下测试环境，和是否成功的实现了无崩溃子类。
测试方法： 调试运行 > 有个msgbox ,点确定关了就行 > 随便点两下按钮,然后直接点vb的 ■ 按钮,直接停止调试> 崩溃了吗?
附: 测试代码
(新版本) 支持Win7 , WinXP, 点此下载(<<<<点击下载)
(旧版本) https://files.cnblogs.com/pctgl/%e6%97%a0%e5%b4%a9%e6%ba%83%e5%ad%90%e7%b1%bb.rar
另外,大家有什么好的建议,请跟帖告之...........
