📄 isbutton.ctl
字号:
Const PATCH_01 As Long = 18 'Code buffer offset to the location of the relative address to EbMode
Const PATCH_02 As Long = 68 'Address of the previous WndProc
Const PATCH_03 As Long = 78 'Relative address of SetWindowsLong
Const PATCH_06 As Long = 116 'Address of the previous WndProc
Const PATCH_07 As Long = 121 'Relative address of CallWindowProc
Const PATCH_0A As Long = 186 'Address of the owner object
Static aBuf(1 To CODE_LEN) As Byte 'Static code buffer byte array
Static pCWP As Long 'Address of the CallWindowsProc
Static pEbMode As Long 'Address of the EbMode IDE break/stop/running function
Static pSWL As Long 'Address of the SetWindowsLong function
Dim i As Long 'Loop index
Dim j As Long 'Loop index
Dim nSubIdx As Long 'Subclass data index
Dim sHex As String 'Hex code string
'If it's the first time through here..
If aBuf(1) = 0 Then
'The hex pair machine code representation.
sHex = "5589E583C4F85731C08945FC8945F8EB0EE80000000083F802742185C07424E830000000837DF800750AE838000000E84D00" & _
"00005F8B45FCC9C21000E826000000EBF168000000006AFCFF7508E800000000EBE031D24ABF00000000B900000000E82D00" & _
"0000C3FF7514FF7510FF750CFF75086800000000E8000000008945FCC331D2BF00000000B900000000E801000000C3E33209" & _
"C978078B450CF2AF75278D4514508D4510508D450C508D4508508D45FC508D45F85052B800000000508B00FF90A4070000C3"
'Convert the string from hex pairs to bytes and store in the static machine code buffer
i = 1
Do While j < CODE_LEN
j = j + 1
aBuf(j) = Val("&H" & Mid$(sHex, i, 2)) 'Convert a pair of hex characters to an eight-bit value and store in the static code buffer array
i = i + 2
Loop 'Next pair of hex characters
'Get API function addresses
If Subclass_InIDE Then 'If we're running in the VB IDE
aBuf(16) = &H90 'Patch the code buffer to enable the IDE state code
aBuf(17) = &H90 'Patch the code buffer to enable the IDE state code
pEbMode = zAddrFunc(MOD_VBA6, FUNC_EBM) 'Get the address of EbMode in vba6.dll
If pEbMode = 0 Then 'Found?
pEbMode = zAddrFunc(MOD_VBA5, FUNC_EBM) 'VB5 perhaps
End If
End If
pCWP = zAddrFunc(MOD_USER, FUNC_CWP) 'Get the address of the CallWindowsProc function
pSWL = zAddrFunc(MOD_USER, FUNC_SWL) 'Get the address of the SetWindowLongA function
ReDim sc_aSubData(0 To 0) As tSubData 'Create the first sc_aSubData element
Else
nSubIdx = zIdx(lng_hWnd, True)
If nSubIdx = -1 Then 'If an sc_aSubData element isn't being re-cycled
nSubIdx = UBound(sc_aSubData()) + 1 'Calculate the next element
ReDim Preserve sc_aSubData(0 To nSubIdx) As tSubData 'Create a new sc_aSubData element
End If
Subclass_Start = nSubIdx
End If
With sc_aSubData(nSubIdx)
.hwnd = lng_hWnd 'Store the hWnd
.nAddrSub = GlobalAlloc(GMEM_FIXED, CODE_LEN) 'Allocate memory for the machine code WndProc
.nAddrOrig = SetWindowLongA(.hwnd, GWL_WNDPROC, .nAddrSub) 'Set our WndProc in place
Call RtlMoveMemory(ByVal .nAddrSub, aBuf(1), CODE_LEN) 'Copy the machine code from the static byte array to the code array in sc_aSubData
Call zPatchRel(.nAddrSub, PATCH_01, pEbMode) 'Patch the relative address to the VBA EbMode api function, whether we need to not.. hardly worth testing
Call zPatchVal(.nAddrSub, PATCH_02, .nAddrOrig) 'Original WndProc address for CallWindowProc, call the original WndProc
Call zPatchRel(.nAddrSub, PATCH_03, pSWL) 'Patch the relative address of the SetWindowLongA api function
Call zPatchVal(.nAddrSub, PATCH_06, .nAddrOrig) 'Original WndProc address for SetWindowLongA, unsubclass on IDE stop
Call zPatchRel(.nAddrSub, PATCH_07, pCWP) 'Patch the relative address of the CallWindowProc api function
Call zPatchVal(.nAddrSub, PATCH_0A, ObjPtr(Me)) 'Patch the address of this object instance into the static machine code buffer
End With
End Function
'Stop all subclassing
Private Sub Subclass_StopAll()
Dim i As Long
i = UBound(sc_aSubData()) 'Get the upper bound of the subclass data array
Do While i >= 0 'Iterate through each element
With sc_aSubData(i)
If .hwnd <> 0 Then 'If not previously Subclass_Stop'd
Call Subclass_Stop(.hwnd) 'Subclass_Stop
End If
End With
i = i - 1 'Next element
Loop
End Sub
'Stop subclassing the passed window handle
Private Sub Subclass_Stop(ByVal lng_hWnd As Long)
'Parameters:
'lng_hWnd - The handle of the window to stop being subclassed
With sc_aSubData(zIdx(lng_hWnd))
Call SetWindowLongA(.hwnd, GWL_WNDPROC, .nAddrOrig) 'Restore the original WndProc
Call zPatchVal(.nAddrSub, PATCH_05, 0) 'Patch the Table B entry count to ensure no further 'before' callbacks
Call zPatchVal(.nAddrSub, PATCH_09, 0) 'Patch the Table A entry count to ensure no further 'after' callbacks
Call GlobalFree(.nAddrSub) 'Release the machine code memory
.hwnd = 0 'Mark the sc_aSubData element as available for re-use
.nMsgCntB = 0 'Clear the before table
.nMsgCntA = 0 'Clear the after table
Erase .aMsgTblB 'Erase the before table
Erase .aMsgTblA 'Erase the after table
End With
End Sub
'======================================================================================================
'These z??? routines are exclusively called by the Subclass_??? routines.
'Worker sub for Subclass_AddMsg
Private Sub zAddMsg(ByVal uMsg As Long, ByRef aMsgTbl() As Long, ByRef nMsgCnt As Long, ByVal When As eMsgWhen, ByVal nAddr As Long)
Dim nEntry As Long 'Message table entry index
Dim nOff1 As Long 'Machine code buffer offset 1
Dim nOff2 As Long 'Machine code buffer offset 2
If uMsg = ALL_MESSAGES Then 'If all messages
nMsgCnt = ALL_MESSAGES 'Indicates that all messages will callback
Else 'Else a specific message number
Do While nEntry < nMsgCnt 'For each existing entry. NB will skip if nMsgCnt = 0
nEntry = nEntry + 1
If aMsgTbl(nEntry) = 0 Then 'This msg table slot is a deleted entry
aMsgTbl(nEntry) = uMsg 'Re-use this entry
Exit Sub 'Bail
ElseIf aMsgTbl(nEntry) = uMsg Then 'The msg is already in the table!
Exit Sub 'Bail
End If
Loop 'Next entry
nMsgCnt = nMsgCnt + 1 'New slot required, bump the table entry count
ReDim Preserve aMsgTbl(1 To nMsgCnt) As Long 'Bump the size of the table.
aMsgTbl(nMsgCnt) = uMsg 'Store the message number in the table
End If
If When = eMsgWhen.MSG_BEFORE Then 'If before
nOff1 = PATCH_04 'Offset to the Before table
nOff2 = PATCH_05 'Offset to the Before table entry count
Else 'Else after
nOff1 = PATCH_08 'Offset to the After table
nOff2 = PATCH_09 'Offset to the After table entry count
End If
If uMsg <> ALL_MESSAGES Then
Call zPatchVal(nAddr, nOff1, VarPtr(aMsgTbl(1))) 'Address of the msg table, has to be re-patched because Redim Preserve will move it in memory.
End If
Call zPatchVal(nAddr, nOff2, nMsgCnt) 'Patch the appropriate table entry count
End Sub
'Return the memory address of the passed function in the passed dll
Private Function zAddrFunc(ByVal sDLL As String, ByVal sProc As String) As Long
zAddrFunc = GetProcAddress(GetModuleHandleA(sDLL), sProc)
' Debug.Assert zAddrFunc 'You may wish to comment out this line if you're using vb5 else the EbMode GetProcAddress will stop here everytime because we look for vba6.dll first
End Function
'Worker sub for Subclass_DelMsg
Private Sub zDelMsg(ByVal uMsg As Long, ByRef aMsgTbl() As Long, ByRef nMsgCnt As Long, ByVal When As eMsgWhen, ByVal nAddr As Long)
Dim nEntry As Long
If uMsg = ALL_MESSAGES Then 'If deleting all messages
nMsgCnt = 0 'Message count is now zero
If When = eMsgWhen.MSG_BEFORE Then 'If before
nEntry = PATCH_05 'Patch the before table message count location
Else 'Else after
nEntry = PATCH_09 'Patch the after table message count location
End If
Call zPatchVal(nAddr, nEntry, 0) 'Patch the table message count to zero
Else 'Else deleteting a specific message
Do While nEntry < nMsgCnt 'For each table entry
nEntry = nEntry + 1
If aMsgTbl(nEntry) = uMsg Then 'If this entry is the message we wish to delete
aMsgTbl(nEntry) = 0 'Mark the table slot as available
Exit Do 'Bail
End If
Loop 'Next entry
End If
End Sub
'Get the sc_aSubData() array index of the passed hWnd
Private Function zIdx(ByVal lng_hWnd As Long, Optional ByVal bAdd As Boolean = False) As Long
'Get the upper bound of sc_aSubData() - If you get an error here, you're probably Subclass_AddMsg-ing before Subclass_Start
zIdx = UBound(sc_aSubData)
Do While zIdx >= 0 'Iterate through the existing sc_aSubData() elements
With sc_aSubData(zIdx)
If .hwnd = lng_hWnd Then 'If the hWnd of this element is the one we're looking for
If Not bAdd Then 'If we're searching not adding
Exit Function 'Found
End If
ElseIf .hwnd = 0 Then 'If this an element marked for reuse.
If bAdd Then 'If we're adding
Exit Function 'Re-use it
End If
End If
End With
zIdx = zIdx - 1 'Decrement the index
Loop
' If Not bAdd Then
' Debug.Assert False 'hWnd not found, programmer error
' End If
'If we exit here, we're returning -1, no freed elements were found
End Function
'Patch the machine code buffer at the indicated offset with the relative address to the target address.
Private Sub zPatchRel(ByVal nAddr As Long, ByVal nOffset As Long, ByVal nTargetAddr As Long)
Call RtlMoveMemory(ByVal nAddr + nOffset, nTargetAddr - nAddr - nOffset - 4, 4)
End Sub
'Patch the machine code buffer at the indicated offset with the passed value
Private Sub zPatchVal(ByVal nAddr As Long, ByVal nOffset As Long, ByVal nValue As Long)
Call RtlMoveMemory(ByVal nAddr + nOffset, nValue, 4)
End Sub
'Worker function for Subclass_InIDE
Private Function zSetTrue(ByRef bValue As Boolean) As Boolean
zSetTrue = True
bValue = True
End Function
'*************************************************************
'
'added by Dennis (dvrdsr) function excerpted vlad memdc class'
'
'*************************************************************
Public Functio⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -