📄 isbutton.ctl
字号:
Private m_Icon As StdPicture
Private m_Font As StdFont
Private m_IconSize As Long
Private m_bEnabled As Boolean
Private m_bShowFocus As Boolean
Private m_bUseCustomColors As Boolean
Private m_lBackColor As Long
Private m_lHighlightColor As Long
Private m_lFontColor As Long
Private m_lFontHighlightColor As Long
Private m_sToolTipText As String
Private m_sTooltiptitle As String
Private m_lToolTipIcon As ttIconType
Private m_lToolTipType As ttStyleEnum
Private m_lttBackColor As Long
Private m_lttForeColor As Long
Private m_lttCentered As Boolean
Private m_lttHwnd As Long
Private m_ButtonType As isbButtonType
Private m_Value As Boolean
Private lPrevStyle As Long
Private dIcon As Boolean
'for subclass
Private sc_aSubData() As tSubData 'Subclass data array
Private bTrack As Boolean
Private bTrackUser32 As Boolean
Private bInCtrl As Boolean
'Auxiliar Variables
Dim lwFontAlign As Long
Dim lPrevButton As Long
Dim OSVI As OSVERSIONINFOEX
Dim ttip As TOOLINFO
'*************************************************************
'
' Public Events
'
'*************************************************************
Public Event Click()
Public Event MouseEnter()
Public Event MouseLeave()
' Paul Caton Self Subclassed template
' http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=54117&lngWId=1
'======================================================================================================
'Subclass handler - MUST be the first Public routine in this file. That includes public properties also
Public Sub zSubclass_Proc(ByVal bBefore As Boolean, ByRef bHandled As Boolean, ByRef lReturn As Long, ByRef lng_hWnd As Long, ByRef uMsg As Long, ByRef wParam As Long, ByRef lParam As Long)
'Parameters:
'bBefore - Indicates whether the the message is being processed before or after the default handler - only really needed if a message is set to callback both before & after.
'bHandled - Set this variable to True in a 'before' callback to prevent the message being subsequently processed by the default handler... and if set, an 'after' callback
'lReturn - Set this variable as per your intentions and requirements, see the MSDN documentation for each individual message value.
'hWnd - The window handle
'uMsg - The message number
'wParam - Message related data
'lParam - Message related data
'Notes:
'If you really know what you're doing, it's possible to change the values of the
'hWnd, uMsg, wParam and lParam parameters in a 'before' callback so that different
'values get passed to the default handler.. and optionaly, the 'after' callback
Static bMoving As Boolean
Select Case uMsg
Case WM_MOUSEMOVE
If Not bInCtrl Then
bInCtrl = True
Call TrackMouseLeave(lng_hWnd)
m_iState = stateHot
Refresh
RaiseEvent MouseEnter
CreateToolTip
End If
Case WM_MOUSELEAVE
bInCtrl = False
m_iState = statenormal
Refresh
RaiseEvent MouseLeave
Case WM_SYSCOLORCHANGE
Refresh
Case WM_THEMECHANGED
Refresh
End Select
End Sub
'======================================================================================================
'Subclass code - The programmer may call any of the following Subclass_??? routines
'Add a message to the table of those that will invoke a callback. You should Subclass_Start first and then add the messages
Private Sub Subclass_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
'Parameters:
'lng_hWnd - The handle of the window for which the uMsg is to be added to the callback table
'uMsg - The message number that will invoke a callback. NB Can also be ALL_MESSAGES, ie all messages will callback
'When - Whether the msg is to callback before, after or both with respect to the the default (previous) handler
With sc_aSubData(zIdx(lng_hWnd))
If When And eMsgWhen.MSG_BEFORE Then
Call zAddMsg(uMsg, .aMsgTblB, .nMsgCntB, eMsgWhen.MSG_BEFORE, .nAddrSub)
End If
If When And eMsgWhen.MSG_AFTER Then
Call zAddMsg(uMsg, .aMsgTblA, .nMsgCntA, eMsgWhen.MSG_AFTER, .nAddrSub)
End If
End With
End Sub
'Delete a message from the table of those that will invoke a callback.
Private Sub Subclass_DelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = MSG_AFTER)
'Parameters:
'lng_hWnd - The handle of the window for which the uMsg is to be removed from the callback table
'uMsg - The message number that will be removed from the callback table. NB Can also be ALL_MESSAGES, ie all messages will callback
'When - Whether the msg is to be removed from the before, after or both callback tables
With sc_aSubData(zIdx(lng_hWnd))
If When And eMsgWhen.MSG_BEFORE Then
Call zDelMsg(uMsg, .aMsgTblB, .nMsgCntB, eMsgWhen.MSG_BEFORE, .nAddrSub)
End If
If When And eMsgWhen.MSG_AFTER Then
Call zDelMsg(uMsg, .aMsgTblA, .nMsgCntA, eMsgWhen.MSG_AFTER, .nAddrSub)
End If
End With
End Sub
'Return whether we're running in the IDE.
Private Function Subclass_InIDE() As Boolean
Debug.Assert zSetTrue(Subclass_InIDE)
End Function
'Start subclassing the passed window handle
Private Function Subclass_Start(ByVal lng_hWnd As Long) As Long
'Parameters:
'lng_hWnd - The handle of the window to be subclassed
'Returns;
'The sc_aSubData() index
Const CODE_LEN As Long = 200 'Length of the machine code in bytes
Const FUNC_CWP As String = "CallWindowProcA" 'We use CallWindowProc to call the original WndProc
Const FUNC_EBM As String = "EbMode" 'VBA's EbMode function allows the machine code thunk to know if the IDE has stopped or is on a breakpoint
Const FUNC_SWL As String = "SetWindowLongA" 'SetWindowLongA allows the cSubclasser machine code thunk to unsubclass the subclasser itself if it detects via the EbMode function that the IDE has stopped
Const MOD_USER As String = "user32" 'Location of the SetWindowLongA & CallWindowProc functions
Const MOD_VBA5 As String = "vba5" 'Location of the EbMode function if running VB5
Const MOD_VBA6 As String = "vba6" 'Location of the EbMode function if running VB6
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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -