Private Declare Function DrawState Lib "user32" Alias "DrawStateA" _
(ByVal hdc As Long, _
ByVal hBrush As Long, _
ByVal lpDrawStateProc As Long, _
ByVal lParam As Long, _
ByVal wParam As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal cX As Long, _
ByVal cY As Long, _
ByVal fuFlags As Long) As Long
'creating button shape
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'drawing the themed button
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Const FOCUSPADDING As Long = 4
Private Declare Function OpenThemeData Lib "uxtheme.dll" _
(ByVal hwnd As Long, ByVal pszClassList As Long) As Long
Private Declare Function CloseThemeData Lib "uxtheme.dll" _
(ByVal hTheme As Long) As Long
Private Declare Function DrawThemeParentBackground Lib "uxtheme.dll" _
(ByVal hwnd As Long, ByVal hdc As Long, prc As RECT) As Long
Private Declare Function DrawThemeBackground Lib "uxtheme.dll" _
(ByVal hTheme As Long, ByVal lHdc As Long, _
ByVal iPartId As Long, ByVal iStateId As Long, _
pRect As RECT, pClipRect As RECT) As Long
Private Declare Function GetThemeBackgroundContentRect Lib "uxtheme.dll" _
(ByVal hTheme As Long, ByVal hdc As Long, _
ByVal iPartId As Long, ByVal iStateId As Long, _
pBoundingRect As RECT, pContentRect As RECT) As Long
Private Declare Function DrawThemeText Lib "uxtheme.dll" _
(ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, _
ByVal iStateId As Long, ByVal pszText As Long, _
ByVal iCharCount As Long, ByVal dwTextFlag As Long, _
ByVal dwTextFlags2 As Long, pRect As RECT) As Long
Public Enum eButtonStyle
Button = 0
Toolbar = 1
End Enum
Private Enum eButtonState
Normal = 1
Hot = 2
Pressed = 3
Disabled = 4
Defaulted = 5
End Enum
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Enum DrawTextFlags
DT_TOP = &H0
DT_LEFT = &H0
DT_CENTER = &H1
DT_RIGHT = &H2
DT_VCENTER = &H4
DT_BOTTOM = &H8
DT_WORDBREAK = &H10
DT_SINGLELINE = &H20
DT_EXPANDTABS = &H40
DT_TABSTOP = &H80
DT_NOCLIP = &H100
DT_EXTERNALLEADING = &H200
DT_CALCRECT = &H400
DT_NOPREFIX = &H800
DT_INTERNAL = &H1000
DT_EDITCONTROL = &H2000
DT_PATH_ELLIPSIS = &H4000
DT_END_ELLIPSIS = &H8000
DT_MODIFYSTRING = &H10000
DT_RTLREADING = &H20000
DT_WORD_ELLIPSIS = &H40000
DT_NOFULLWIDTHCHARBREAK = &H80000
DT_HIDEPREFIX = &H100000
DT_PREFIXONLY = &H200000
End Enum
Public Enum eAlignment
topleft = DT_TOP Or DT_LEFT Or DT_SINGLELINE 'left top
topcenter = DT_TOP Or DT_CENTER Or DT_SINGLELINE 'top center
topright = DT_TOP Or DT_RIGHT Or DT_SINGLELINE 'top right
middleleft = DT_VCENTER Or DT_LEFT Or DT_SINGLELINE 'middle left
middlecenter = DT_VCENTER Or DT_CENTER Or DT_SINGLELINE 'middle center
middleright = DT_VCENTER Or DT_RIGHT Or DT_SINGLELINE 'middle right
bottomleft = DT_BOTTOM Or DT_LEFT Or DT_SINGLELINE 'bottom left
bottomcenter = DT_BOTTOM Or DT_CENTER Or DT_SINGLELINE 'bottom center
bottomright = DT_BOTTOM Or DT_RIGHT Or DT_SINGLELINE 'bottom right
End Enum
'mouse position
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'INTERNAL USE
Private m_Hot As Boolean 'is the mouse over the control?
Private m_MouseDown As Boolean 'is the mouse down?
Private m_StateIdButton As eButtonState 'the current draw state of the button
Private m_Active As Boolean 'are we the active app? ie we dont process mouse over events unless we have focus
Private m_Caption As String 'text for the button
Private m_CaptionAlignment As eAlignment 'alignment for text
Private m_Enabled As Boolean 'Enabled?
Private m_UseThemes As Boolean 'Which button to use
Private m_HasFocus As Boolean 'Does button have focus?
Private m_DisplayAsDefault As Boolean
Private m_FocusRect As Boolean 'Do we draw the focus rectangle?
Private m_ButtonStyle As eButtonStyle 'Which theme to use when drawing
Private m_Picture As StdPicture
Private m_PictureAlignment As eAlignment 'alignment for picture
Private m_PicturePadding As Long 'How many pixels to indent
Private m_CaptionPadding As Long 'How many pixels to indent
'we dont want to send 2 click events if the user has mouse down
'over the control and presses enter so we set which input type
'has priority and only the latest event will be processed
MSG_AFTER = 1 'Message calls back after the original (previous) WndProc
MSG_BEFORE = 2 'Message calls back before the original (previous) WndProc
MSG_BEFORE_AND_AFTER = MSG_AFTER Or MSG_BEFORE 'Message calls back before and after the original (previous) WndProc
End Enum
Private Type tSubData 'Subclass data type
hwnd As Long 'Handle of the window being subclassed
nAddrSub As Long 'The address of our new WndProc (allocated memory).
nAddrOrig As Long 'The address of the pre-existing WndProc
nMsgCntA As Long 'Msg after table entry count
nMsgCntB As Long 'Msg before table entry count
aMsgTblA() As Long 'Msg after table array
aMsgTblB() As Long 'Msg Before table array
End Type
Private sc_aSubData() As tSubData 'Subclass data array
Private Const ALL_MESSAGES As Long = -1 'All messages added or deleted
Private Const GMEM_FIXED As Long = 0 'Fixed memory GlobalAlloc flag
Private Const GWL_WNDPROC As Long = -4 'Get/SetWindow offset to the WndProc procedure address
Private Const PATCH_04 As Long = 88 'Table B (before) address patch offset
Private Const PATCH_05 As Long = 93 'Table B (before) entry count patch offset
Private Const PATCH_08 As Long = 132 'Table A (after) address patch offset
Private Const PATCH_09 As Long = 137 'Table A (after) entry count patch offset
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Window Messages
Private Const WM_ACTIVATE = &H6
Private Const WM_NCACTIVATE As Long = &H86
Private Const WM_MOUSELEAVE As Long = &H2A3
Private Const WM_SYSCOLORCHANGE As Long = &H15
Private Const WM_THEMECHANGED As Long = &H31A
'//Mouse tracking declares
Private Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENT_STRUCT) As Long
Private Enum TRACKMOUSEEVENT_FLAGS
TME_HOVER = &H1&
TME_LEAVE = &H2&
TME_QUERY = &H40000000
TME_CANCEL = &H80000000
End Enum
Private Type TRACKMOUSEEVENT_STRUCT
cbSize As Long
dwFlags As TRACKMOUSEEVENT_FLAGS
hwndTrack As Long
dwHoverTime As Long
End Type
'Subclass handler
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)
Attribute zSubclass_Proc.VB_MemberFlags = "40"
'THIS MUST BE THE FIRST PUBLIC ROUTINE IN THIS FILE.
'That includes public properties also
'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
'Debug.Print WMbyName(uMsg) & " " & wParam
Select Case uMsg
Case WM_THEMECHANGED, WM_SYSCOLORCHANGE
InitialiseThemes
Refresh
Case WM_MOUSELEAVE
'called when mouse leaves the control
If ProcessingMessages Then
m_Hot = False
m_MouseDown = False
If Not m_EBP = Keyboard Then 'if there isnt a keyboard event stored, eg they are holding down the spacebar, then refresh
RefreshButton
End If
End If
Case WM_ACTIVATE, WM_NCACTIVATE
If wParam Then '----------------------------------- Activated
Private Function Subclass_Start(ByVal lng_hWnd As Long) As Long
On Error GoTo Errs
'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
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)
On Error GoTo Errs
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
Errs:
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
On Error GoTo Errs
'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.
