Release the ultimate version of iSubClass, an efficient, non-crash-free subclassing
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:
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
Re: Release the ultimate version of iSubClass, an efficient, non-crash-free subclassi
Case WM_MOUSEMOVE
Case WM_MOUSELEAVE
MouseEnter and MouseExit
Code:
Dim WithEvents MouseOnOut1 As MouseOnOut
Private Sub Form_Load()
Set MouseOnOut1 = New MouseOnOut
MouseOnOut1.StartHook Picture1.Hwnd
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Set MouseOnOut1 = Nothing
End Sub
Private Sub MouseOnOut1_MouseOn()
Debug.Print "MouseOnOut1_MouseOn"
End Sub
Private Sub MouseOnOut1_MouseOut()
Debug.Print "MouseOnOut1_MouseOut"
End Sub
Re: Release the ultimate version of iSubClass, an efficient, non-crash-free subclassi
MouseEnter MouseExit without subclass
form1.frm
Code:
Private Sub Form_Load()
Bind Picture1
Bind Picture2
End Sub
Public Sub MoveOn(ControlName As String)
Debug.Print "MoveOn-" & ControlName
End Sub
Public Sub MoveOut(ControlName As String)
Debug.Print "MoveOut-" & ControlName
Select Case ControlName
Case "Picture1"
Debug.Print Now & " Do Picture1-MouseOut"
End Select
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Debug.Print "UNLOAD FORM"
End Sub
module1.bas
Code:
Option Explicit
Public Const WM_MOUSELEAVE = &H2A3&
Public Const WM_MOUSEMOVE = &H200
Private Type TRACKMOUSEEVENTTYPE
cbSize As Long
dwFlags As Long
hwndTrack As Long
dwHoverTime As Long
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 IsWindow Lib "user32" (ByVal hWnd As Long) As Long
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 TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENTTYPE) As Long
Private Const GWL_WNDPROC = (-4)
Private Const WM_NCDESTROY = &H82
Private Const TME_LEAVE = &H2&
Public OldProcList As New Collection
Public FormList As New Collection
Public MoveOnList As New Collection
Public ControlNameList As New Collection
Public FormOldProcList As New Collection
Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hWnd As Long, ByVal lpString As Long, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hWnd As Long, ByVal lpString As Long) As Long
Public Function Bind(Control1 As Control) As Boolean
Dim hWnd As Long, m_OldProc As Long, ControlName As String
hWnd = Control1.hWnd
If IsWindow(hWnd) Then
FormList.Add Control1.Parent, hWnd & ""
MoveOnList.Add 0, hWnd & ""
On Error Resume Next
Dim ControlIndex As Long
ControlIndex = -1
ControlIndex = Control1.Index
ControlName = Control1.Name & IIf(ControlIndex <> -1, "(" & ControlIndex & ")", "")
ControlNameList.Add ControlName, hWnd & ""
m_OldProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf ControlCallBack)
OldProcList.Add m_OldProc, hWnd & ""
Debug.Print "ControlName=" & ControlName & ",Hwnd=" & hWnd & ",m_OldProc=" & m_OldProc
SetProp hWnd, StrPtr("m_OldProc"), m_OldProc
'BindForm Control1.Parent.Hwnd
End If
End Function
Sub BindForm(hWnd As Long)
On Error Resume Next
Dim m_OldProc As Long
m_OldProc = FormOldProcList(hWnd & "")
If m_OldProc = 0 Then
m_OldProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf FormCallBack)
FormOldProcList.Add m_OldProc, hWnd & ""
End If
End Sub
Sub UnbindForm(hWnd As Long)
On Error Resume Next
Dim m_OldProc As Long
m_OldProc = FormOldProcList(hWnd & "")
If m_OldProc <> 0 Then
Call SetWindowLong(hWnd, GWL_WNDPROC, m_OldProc)
FormOldProcList.Remove hWnd & ""
End If
End Sub
Public Function Unbind(hWnd) As Boolean
On Error Resume Next
Dim m_OldProc As Long
m_OldProc = OldProcList(hWnd & "")
If m_OldProc <> 0 Then
Unbind = CBool(SetWindowLong(hWnd, GWL_WNDPROC, m_OldProc))
OldProcList.Remove hWnd & ""
FormList.Remove hWnd & ""
ControlNameList.Remove hWnd & ""
MoveOnList.Remove hWnd & ""
End If
End Function
Private Function FormCallBack(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim m_OldProc As Long
m_OldProc = FormOldProcList(hWnd & "")
FormCallBack = CallWindowProc(m_OldProc, hWnd, Msg, wParam, lParam)
If Msg = WM_NCDESTROY Then
Debug.Print "Unload Form:" & hWnd
UnbindForm hWnd
End If
End Function
Private Function ControlCallBack(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error GoTo err
Dim m_OldProc As Long
m_OldProc = OldProcList(hWnd & "")
'鼠标在其上移动，当前未标识为跟踪状态(第一次或者移开鼠标后重新移动回来时)
If Msg = WM_MOUSEMOVE Then
If MoveOnList(hWnd & "") = 0 Then
MoveOnList.Remove hWnd & ""
MoveOnList.Add 1, hWnd & ""
Dim tTrackML As TRACKMOUSEEVENTTYPE '一个移开事件结构声明
tTrackML.cbSize = Len(tTrackML)
tTrackML.hwndTrack = hWnd
tTrackML.dwFlags = TME_LEAVE
TrackMouseEvent tTrackML
FormList(hWnd & "").MoveOn ControlNameList(hWnd & "")
'Debug.Print Now & "--WM_MOUSEMOVE"
End If
ElseIf Msg = WM_MOUSELEAVE Then '鼠标移开时，取消跟踪状态
MoveOnList.Remove hWnd & ""
MoveOnList.Add 0, hWnd & ""
FormList(hWnd & "").MoveOut ControlNameList(hWnd & "")
End If
ControlCallBack = CallWindowProc(m_OldProc, hWnd, Msg, wParam, lParam)
If Msg = WM_NCDESTROY Then
Debug.Print "Removed:" & ControlNameList(hWnd & "")
Call Unbind(hWnd)
End If
Exit Function
err:
m_OldProc = GetProp(hWnd, StrPtr("m_OldProc"))
Debug.Print "hWnd=" & hWnd & ",err:" & err.Description & ",m_OldProc=" & m_OldProc
Call SetWindowLong(hWnd, GWL_WNDPROC, m_OldProc)
End Function
Reply With Quote