I didn't plan to write a new iSubClass, and the problem with no crashes in previous versions has not been perfectly resolved
In the past two days mines, I don't know what crazy to suddenly smoke, carefully studied the class that does not collapse subclassing, and found VBA6.dll:: EBMode
This function can get the state of the vb debugger in the IDE state Return Value: 0 The debugger stops; 1 The debugger is running normally; 2 The debugger is broken
Very powerful... According to the information provided by ws mines, the previous version of iSubClass was slightly modified, and finally achieved basically stable, non-crashing subclass code, and powerful efficiency.
The single-class subclass code that comes from is messy and inefficient (open a few more instances at the same time, the program will be very stuck), and the only advantage may be stability
Now there are still a few minor problems with this code:
1. Stop with ■ interrupt, there will be 64 bytes of resource leakage, but the problem is not big, and there is no problem after compilation, users can completely ignore it.
2. When the debugging is interrupted (temporary state, not exiting debugging) caused by the error code, it may temporarily cause the VB toolbar to freeze, it seems that the problem is not big, just click ▲ or ■ more
Other problems, I haven't found it yet, if you have it, please follow the post...
This modification, the code interface has been slightly modified, mainly to look good, if you want to replace the code that has been done before, go to the website of the horse and ask for the version obtained before the horse.
The code of the horse can directly delete the original iSubClass and replace it with a new one, and the interface code has not changed at all, and it can be used directly.
If you use the code of this post, you may need to change it, the name of the event has been changed to MsgHook, and the inline function has been changed to GetWindowMessage
Then I optimized the code, and there were many clerical errors in the version of the horse that were not changed
code from:https://www.cnblogs.com/pctgl/articles/3150552.html
In the past two days mines, I don't know what crazy to suddenly smoke, carefully studied the class that does not collapse subclassing, and found VBA6.dll:: EBMode
This function can get the state of the vb debugger in the IDE state Return Value: 0 The debugger stops; 1 The debugger is running normally; 2 The debugger is broken
Very powerful... According to the information provided by ws mines, the previous version of iSubClass was slightly modified, and finally achieved basically stable, non-crashing subclass code, and powerful efficiency.
The single-class subclass code that comes from is messy and inefficient (open a few more instances at the same time, the program will be very stuck), and the only advantage may be stability
Now there are still a few minor problems with this code:
1. Stop with ■ interrupt, there will be 64 bytes of resource leakage, but the problem is not big, and there is no problem after compilation, users can completely ignore it.
2. When the debugging is interrupted (temporary state, not exiting debugging) caused by the error code, it may temporarily cause the VB toolbar to freeze, it seems that the problem is not big, just click ▲ or ■ more
Other problems, I haven't found it yet, if you have it, please follow the post...
This modification, the code interface has been slightly modified, mainly to look good, if you want to replace the code that has been done before, go to the website of the horse and ask for the version obtained before the horse.
The code of the horse can directly delete the original iSubClass and replace it with a new one, and the interface code has not changed at all, and it can be used directly.
If you use the code of this post, you may need to change it, the name of the event has been changed to MsgHook, and the inline function has been changed to GetWindowMessage
Then I optimized the code, and there were many clerical errors in the version of the horse that were not changed
Code:
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