VB6 发布终极版 iSubClass ， 高效、不崩溃子类化代码-ZT今天 09:18
本来不打算再写新的 iSubClass ， 之前的版本有关 无崩溃 的问题一直没有完美解决
这两天 地雷 ， 不知道突然抽什么疯， 仔细研究了一下泊来的那个不崩溃子类化的类， 发现了 vba6.dll:: EbMode
这个函数能够在 IDE 状态下获取 vb 调试器的状态 Return Value： 0 调试器停止； 1 调试器正常运行； 2 调试器被中断
很强大。。。根据 ws地雷提供的信息， 对之前版本的 iSubClass 稍稍改造了一下， 终于实现了基本稳定，不崩溃的子类化代码，而且兼具强悍效率。
泊来的那个单类子类化代码，又乱，又不高效（同时多开几个实例，程序会很卡），可能唯一的好处就是稳定了
现在这个代码还是有几个小问题：
1. 用 ■ 中断停止， 会有 64 字节的资源泄漏，不过问题不大，且编译后不存在这个问题， 使用者完全可以无视。
2. 遇有错误代码导致的调试中断（暂时状态，非退出调试）时，可能会临时性的引起vb工具栏的冻结，貌似也问题不大，多点几下 ▲ 或者 ■ 就行了
其他问题，暂时还没发现，如有请跟帖告之。。。
本次修改， 对代码接口稍有修改，主要是为了看着顺眼，如果要替换之前已做好的代码，去马子的网站要马子之前拿到的版本。
马子的那份代码可以直接把原来的 iSubClass 删掉， 换新的即可，接口代码一点没变，直接用。
要是用本帖的代码， 可能你需要修改一下， 事件的名字改了一下， 改成了 MsgHook ，内接函数改成了 GetWindowMessage
然后就是优化了一下代码，给马子的版本里面有很多笔误代码没改掉
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As Long = 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
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long
Private Type ThisClassSet
s_DefaultWindowProc As Long
s_Hwnd As Long
s_BlockProtect As Long
n_ThunkCodeAddress As Long
End Type
Dim LinkProc() As Long
Dim PG As ThisClassSet
Event MsgHook(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
Private Sub GetWindowMessage(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
'子类化接口过程
RaiseEvent MsgHook(Result, cHwnd, Message, wParam, lParam)
End Sub
Private Function GetWndProcAddress(ByVal SinceCount As Long) As Long
' 地址指针 ＝ GetWndProcAddress( 取第 N 个公共函数（属性） =或= 所有公共函数个数 + 第 N 个私有函数的函数地址）
Dim mePtr As Long
Dim jmpAddress As Long
mePtr = ObjPtr(Me)
CopyMemory jmpAddress, ByVal mePtr, 4
CopyMemory jmpAddress, ByVal jmpAddress + (SinceCount - 1) * 4 + &H1C, 4
If App.LogMode = 0 Then
ReDim LinkProc(15) As Long
LinkProc(0) = &H83EC8B55
LinkProc(1) = &H75FFFCC4
LinkProc(2) = &H1075FF14
LinkProc(3) = &HFF0C75FF
LinkProc(4) = &HB90875
LinkProc(5) = &HFF000010
LinkProc(6) = &H1F883D1
LinkProc(7) = &H4D8D1575
LinkProc(8) = &H6851FC
LinkProc(9) = &HB8000020
LinkProc(10) = &H3000
LinkProc(11) = &H458BD0FF
LinkProc(12) = &HB807EBFC
LinkProc(13) = &H4000
LinkProc(14) = &HC2C9D0FF
LinkProc(15) = &H10
CopyMemory ByVal VarPtr(LinkProc(4)) + 3, GetProcAddress(GetModuleHandle("vba6.dll"), "EbMode"), 4&
CopyMemory ByVal VarPtr(LinkProc(8)) + 3, ObjPtr(Me), 4&
LinkProc(10) = jmpAddress
LinkProc(13) = PG.s_DefaultWindowProc
PG.n_ThunkCodeAddress = HeapAlloc(GetProcessHeap, &H8, 64&)
CopyMemory ByVal PG.n_ThunkCodeAddress, LinkProc(0), 64&
VirtualProtect ByVal PG.n_ThunkCodeAddress, ByVal 64&, ByVal &H40&, PG.s_BlockProtect
GetWndProcAddress = PG.n_ThunkCodeAddress
Else
ReDim LinkProc(10)
LinkProc(0) = &H83EC8B55
LinkProc(1) = &H75FFFCC4
LinkProc(2) = &H1075FF14
LinkProc(3) = &HFF0C75FF
LinkProc(4) = &H458D0875
LinkProc(5) = &H6850FC
LinkProc(6) = &HB8000010
LinkProc(7) = &H2000
LinkProc(8) = &H458BD0FF
LinkProc(9) = &H10C2C9FC
CopyMemory ByVal VarPtr(LinkProc(5)) + 3, ObjPtr(Me), 4&
LinkProc(7) = jmpAddress
VirtualProtect ByVal VarPtr(LinkProc(0)), ByVal 40&, ByVal &H40&, PG.s_BlockProtect
GetWndProcAddress = VarPtr(LinkProc(0))
End If
End Function
Function CallDefaultWindowProc(ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'调用窗口默认处理过程
CallDefaultWindowProc = CallWindowProc(PG.s_DefaultWindowProc, ByVal cHwnd&, ByVal Message&, ByVal wParam&, ByVal lParam&)
End Function
Function SetMsgHook(ByVal cHwnd As Long) As Long
'设置指定窗口的子类化
PG.s_Hwnd = cHwnd
PG.s_DefaultWindowProc = GetWindowLong(cHwnd, ByVal -4&)
SetWindowLong ByVal cHwnd, ByVal -4&, ByVal GetWndProcAddress(4)
SetMsgHook = PG.s_DefaultWindowProc
End Function
Sub SetMsgUnHook()
'取消窗口子类化
SetWindowLong ByVal PG.s_Hwnd&, ByVal -4&, ByVal PG.s_DefaultWindowProc&
If PG.n_ThunkCodeAddress Then
VirtualProtect ByVal PG.n_ThunkCodeAddress, ByVal 64&, ByVal PG.s_BlockProtect, PG.s_BlockProtect
HeapFree GetProcessHeap, ByVal 0&, PG.n_ThunkCodeAddress
PG.n_ThunkCodeAddress = 0
End If
End Sub
Private Sub Class_Terminate()
SetMsgUnHook
End Sub
''// 在编译后, GetWndProcAddress 释放以下内嵌汇编代码, 效率最大化
''ComCallBack1 proc hWnd,Msg,wParam,lParam
''
'' LOCAL Result
''
'' push lParam
'' push wParam
'' push Msg
'' push hWnd
''
'' lea eax, Result
'' push eax ;//
''
'' push 1000h ;// objptr(me)
''
'' mov eax,2000h ;// sub: LinkProc
'' Call eax
''
'' mov eax,Result ;// Return Value
''
'' ret
''ComCallBack1 endp
''
''============================================================================================================================================
''
''// 在 IDE 调试运行时, GetWndProcAddress 释放以下内嵌汇编代码, 用以实现在调试时不崩溃
''ComCallBack proc hWnd,Msg,wParam,lParam
''
'' LOCAL Result
''
'' push lParam
'' push wParam
'' push Msg
'' push hWnd
''
'' mov ecx,1000h
'' call ecx ;// call vba6.dll::EbMode
''
'' .if eax == 1
'' ;// 调试模式下正常运行
'' lea ecx, Result
'' push ecx ;// result
'' push 2000h ;// objptr(me)
'' mov eax,3000h ;// sub: LinkProc
'' Call eax
''
'' mov eax, Result
''
'' .else
'' ;// 调试模式下非正常运行, 中断 打断 断点 结束
'' mov eax,4000h ;// sub: Deault Window Proc
'' Call eax
''
'' .endif
''
'' ret
''
''ComCallBack endp
iSubClass
全部回复（0）