📄 candybutton.ctl
字号:
Dim nAddr As Long
Dim nID As Long
Dim nMyID As Long
If IsWindow(lng_hWnd) = 0 Then 'Ensure the window handle is valid
zError SUB_NAME, "Invalid window handle"
Exit Function
End If
nMyID = GetCurrentProcessId 'Get this process's ID
GetWindowThreadProcessId lng_hWnd, nID 'Get the process ID associated with the window handle
If nID <> nMyID Then 'Ensure that the window handle doesn't belong to another process
zError SUB_NAME, "Window handle belongs to another process"
Exit Function
End If
If oCallback Is Nothing Then 'If the user hasn't specified the callback owner
Set oCallback = Me 'Then it is me
End If
nAddr = zAddressOf(oCallback, nOrdinal) 'Get the address of the specified ordinal method
If nAddr = 0 Then 'Ensure that we've found the ordinal method
zError SUB_NAME, "Callback method not found"
Exit Function
End If
If z_Funk Is Nothing Then 'If this is the first time through, do the one-time initialization
Set z_Funk = New Collection 'Create the hWnd/thunk-address collection
z_Sc(14) = &HD231C031: z_Sc(15) = &HBBE58960: z_Sc(17) = &H4339F631: z_Sc(18) = &H4A21750C: z_Sc(19) = &HE82C7B8B: z_Sc(20) = &H74&: z_Sc(21) = &H75147539: z_Sc(22) = &H21E80F: z_Sc(23) = &HD2310000: z_Sc(24) = &HE8307B8B: z_Sc(25) = &H60&: z_Sc(26) = &H10C261: z_Sc(27) = &H830C53FF: z_Sc(28) = &HD77401F8: z_Sc(29) = &H2874C085: z_Sc(30) = &H2E8&: z_Sc(31) = &HFFE9EB00: z_Sc(32) = &H75FF3075: z_Sc(33) = &H2875FF2C: z_Sc(34) = &HFF2475FF: z_Sc(35) = &H3FF2473: z_Sc(36) = &H891053FF: z_Sc(37) = &HBFF1C45: z_Sc(38) = &H73396775: z_Sc(39) = &H58627404
z_Sc(40) = &H6A2473FF: z_Sc(41) = &H873FFFC: z_Sc(42) = &H891453FF: z_Sc(43) = &H7589285D: z_Sc(44) = &H3045C72C: z_Sc(45) = &H8000&: z_Sc(46) = &H8920458B: z_Sc(47) = &H4589145D: z_Sc(48) = &HC4836124: z_Sc(49) = &H1862FF04: z_Sc(50) = &H35E30F8B: z_Sc(51) = &HA78C985: z_Sc(52) = &H8B04C783: z_Sc(53) = &HAFF22845: z_Sc(54) = &H73FF2775: z_Sc(55) = &H1C53FF28: z_Sc(56) = &H438D1F75: z_Sc(57) = &H144D8D34: z_Sc(58) = &H1C458D50: z_Sc(59) = &HFF3075FF: z_Sc(60) = &H75FF2C75: z_Sc(61) = &H873FF28: z_Sc(62) = &HFF525150: z_Sc(63) = &H53FF2073: z_Sc(64) = &HC328&
z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcA") 'Store CallWindowProc function address in the thunk data
z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongA") 'Store the SetWindowLong function address in the thunk data
z_Sc(IDX_FREE) = zFnAddr("kernel32", "VirtualFree") 'Store the VirtualFree function address in the thunk data
z_Sc(IDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr") 'Store the IsBadCodePtr function address in the thunk data
End If
z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX) 'Allocate executable memory
If z_ScMem <> 0 Then 'Ensure the allocation succeeded
On Error GoTo CatchDoubleSub 'Catch double subclassing
z_Funk.Add z_ScMem, "h" & lng_hWnd 'Add the hWnd/thunk-address to the collection
On Error GoTo 0
If bIdeSafety Then 'If the user wants IDE protection
z_Sc(IDX_EBMODE) = zFnAddr("vba6", "EbMode") 'Store the EbMode function address in the thunk data
End If
z_Sc(IDX_EBX) = z_ScMem 'Patch the thunk data address
z_Sc(IDX_HWND) = lng_hWnd 'Store the window handle in the thunk data
z_Sc(IDX_BTABLE) = z_ScMem + CODE_LEN 'Store the address of the before table in the thunk data
z_Sc(IDX_ATABLE) = z_ScMem + CODE_LEN + ((MSG_ENTRIES + 1) * 4) 'Store the address of the after table in the thunk data
z_Sc(IDX_OWNER) = ObjPtr(oCallback) 'Store the callback owner's object address in the thunk data
z_Sc(IDX_CALLBACK) = nAddr 'Store the callback address in the thunk data
z_Sc(IDX_PARM_USER) = lParamUser 'Store the lParamUser callback parameter in the thunk data
nAddr = SetWindowLongA(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF) 'Set the new WndProc, return the address of the original WndProc
If nAddr = 0 Then 'Ensure the new WndProc was set correctly
zError SUB_NAME, "SetWindowLong failed, error #" & Err.LastDllError
GoTo ReleaseMemory
End If
z_Sc(IDX_WNDPROC) = nAddr 'Store the original WndProc address in the thunk data
RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN 'Copy the thunk code/data to the allocated memory
sc_Subclass = True 'Indicate success
Else
zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError
End If
Exit Function 'Exit sc_Subclass
CatchDoubleSub:
zError SUB_NAME, "Window handle is already subclassed"
ReleaseMemory:
VirtualFree z_ScMem, 0, MEM_RELEASE 'sc_Subclass has failed after memory allocation, so release the memory
End Function
'Terminate all subclassing
Private Sub sc_Terminate()
Dim i As Long
If Not (z_Funk Is Nothing) Then 'Ensure that subclassing has been started
With z_Funk
For i = .Count To 1 Step -1 'Loop through the collection of window handles in reverse order
z_ScMem = .Item(i) 'Get the thunk address
If IsBadCodePtr(z_ScMem) = 0 Then 'Ensure that the thunk hasn't already released its memory
sc_UnSubclass zData(IDX_HWND) 'UnSubclass
End If
Next i 'Next member of the collection
End With
Set z_Funk = Nothing 'Destroy the hWnd/thunk-address collection
End If
End Sub
'UnSubclass the specified window handle
Private Sub sc_UnSubclass(ByVal lng_hWnd As Long)
If z_Funk Is Nothing Then 'Ensure that subclassing has been started
zError "sc_UnSubclass", "Window handle isn't subclassed"
Else
If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then 'Ensure that the thunk hasn't already released its memory
zData(IDX_SHUTDOWN) = -1 'Set the shutdown indicator
zDelMsg ALL_MESSAGES, IDX_BTABLE 'Delete all before messages
zDelMsg ALL_MESSAGES, IDX_ATABLE 'Delete all after messages
End If
z_Funk.Remove "h" & lng_hWnd 'Remove the specified window handle from the collection
End If
End Sub
'Add the message value to the window handle's specified callback table
Private Sub sc_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = eMsgWhen.MSG_AFTER)
If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then 'Ensure that the thunk hasn't already released its memory
If When And MSG_BEFORE Then 'If the message is to be added to the before original WndProc table...
zAddMsg uMsg, IDX_BTABLE 'Add the message to the before table
End If
If When And MSG_AFTER Then 'If message is to be added to the after original WndProc table...
zAddMsg uMsg, IDX_ATABLE 'Add the message to the after table
End If
End If
End Sub
'Delete the message value from the window handle's specified callback table
Private Sub sc_DelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = eMsgWhen.MSG_AFTER)
If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then 'Ensure that the thunk hasn't already released its memory
If When And MSG_BEFORE Then 'If the message is to be deleted from the before original WndProc table...
zDelMsg uMsg, IDX_BTABLE 'Delete the message from the before table
End If
If When And MSG_AFTER Then 'If the message is to be deleted from the after original WndProc table...
zDelMsg uMsg, IDX_ATABLE 'Delete the message from the after table
End If
End If
End Sub
'Call the original WndProc
Private Function sc_CallOrigWndProc(ByVal lng_hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then 'Ensure that the thunk hasn't already released its memory
sc_CallOrigWndProc = _
CallWindowProcA(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam) 'Call the original WndProc of the passed window handle parameter
End If
End Function
'Get the subclasser lParamUser callback parameter
Private Property Get sc_lParamUser(ByVal lng_hWnd As Long) As Long
If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then 'Ensure that the thunk hasn't already released its memory
sc_lParamUser = zData(IDX_PARM_USER) 'Get the lParamUser callback parameter
End If
End Property
'Let the subclasser lParamUser callback parameter
Private Property Let sc_lParamUser(ByVal lng_hWnd As Long, ByVal newValue As Long)
If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then 'Ensure that the thunk hasn't already released its memory
zData(IDX_PARM_USER) = newValue 'Set the lParamUser callback parameter
End If
End Property
'-The following routines are exclusively for the sc_ subclass routines----------------------------
'Add the message to the specified table of the window handle
Private Sub zAddMsg(ByVal uMsg As Long, ByVal nTable As Long)
Dim nCount As Long 'Table entry count
Dim nBase As Long 'Remember z_ScMem
Dim i As Long 'Loop index
nBase = z_ScMem 'Remember z_ScMem so that we can restore its value on exit
z_ScMem = zData(nTable) 'Map zData() to the specified table
If uMsg = ALL_MESSAGES Then 'If ALL_MESSAGES are being added to the table...
nCount = ALL_MESSAGES 'Set the table entry count to ALL_MESSAGES
Else
nCount = zData(0) 'Get the current table entry count
If nCount >= MSG_ENTRIES Then 'Check for message table overflow
zError "zAddMsg", "Message table overflow. Either increase the value of Const MSG_ENTRIES or use ALL_MESSAGES instead of specific message values"
GoTo Bail
End If
For i = 1 To nCount 'Loop through the table entries
If zData(i) = 0 Then 'If the element is free...
zData(i) = uMsg 'Use this element
GoTo Bail 'Bail
ElseIf zData(i) = uMsg Then 'If the message is already in the table...
GoTo Bail 'Bail
End If
Next i 'Next message table entry
nCount = i 'On drop through: i = nCount + 1, the new table entry count
zData(nCount) = uMsg 'Store the message in the appended table entry
End If
zData(0) = nCount 'Store the new table entry count
Bail:
z_ScMem = nBase 'Restore the value of z_ScMem
End Sub
'Delete the message from the specified table of the window handle
Private Sub zDelMsg(ByVal uMsg As Long, ByVal nTable As Long)
Dim nCount As Long 'Table entry count
Dim nBase As Long 'Remember z_ScMem
Dim i As Long 'Loop index
nBase = z_ScMem 'Remember z_ScMem so that we can restore its value on exit
z_ScMem = zData(nTable) 'Map zData() to the specified table
If uMsg = ALL_MESSAGES Then 'If ALL_MESSAGES are being deleted from the table...
zData(0) = 0 'Zero the table entry count
Else
nCount = zData(0) 'Get the table entry count
For i = 1 To nCount 'Loop through the table entries
If zData(i) = uMsg Then 'If the message is found...
zData(i) = 0 'Null the msg value -- also frees the element for re-use
GoTo Bail 'Bail
End If
Next i 'Next message table entry
zError "zDelMsg", "Message &H" & Hex$(uMsg) & " not found in table"
End If
Bail:
z_ScMem = nBase 'Restore the value of z_ScMem
End Sub
'Error handler
Private Sub zError(ByVal sRoutine As String, ByVal sMsg As String)
App.LogEvent TypeName(Me) & "." & sRoutine & ": " & sMsg, vbLogEventTypeError
MsgBox sMsg & ".", vbExclamation + vbApplicationModal, "Error in " & TypeName(Me) & "." & sRoutine
End Sub
'Return the address of the specified DLL/procedure
Private Function zFnAddr(ByVal sDLL As String, ByVal sProc As String) As Long
zFnAddr = GetProcAddress(GetModuleHandleA(sDLL), sProc) 'Get the specified procedure address
Debug.Assert zFnAddr 'In the IDE, validate that the procedure address was located
End Function
'Map zData() to the thunk address for the specified window handle
Private Function zMap_hWnd(ByVal lng_hWnd As Long) As Long
If z_Funk Is Nothing Then 'Ensure that subclassing has been started
zError "zMap_hWnd", "Subclassing hasn't been started"
Else
On Error GoTo Catch 'Catch unsubclassed window handles
z_ScMem = z_Funk("h" & lng_hWnd) 'Get the thunk address
zMap_hWnd = z_ScMem
End If
Exit Function 'Exit returning the thunk address
Catch:
zError "zMap_hWnd", "Window handle isn't subclassed"
End Function
'Return the address of the specified ordinal method on the oCallback object, 1 = last private method, 2 = second last private method, etc
Private Function zAddressOf(ByVal oCallback As Object, ByVal nOrdinal As Long) As Long
Dim bSub As Byte 'Value we expect to find pointed at by a vTable method entry
Dim bVal As Byte
Dim nAddr As Long 'Address of the vTable
Dim i As Long 'Loop index
Dim j As Long 'Loop limit
RtlMoveMemory VarPtr(nAddr), ObjPtr(oCallback), 4 'Get the address of the callback object's instance
If Not zProbe(nAddr + &H1C, i, bSub) Then 'Probe for a Class method
If Not zProbe(nAddr + &H6F8, i, bSub) Then 'Probe for a Form method
If Not zProbe(nAddr + &H7A4, i, bSub) Then 'Probe for a UserControl method
Exit Function 'Bail...
End If
End If
End If
i = i + 4 'Bump to the next entry
j = i + 1024 ⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -