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
'//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
Private Const WM_MOUSELEAVE As Long = &H2A3
'//DrawText declares
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const DT_VCENTER As Long = &H4
Private Const DT_SINGLELINE As Long = &H20
Private Const DT_FLAGS As Long = DT_VCENTER + DT_SINGLELINE
Private Const DT_CENTER As Long = &H1
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
'//Gradient Fill Declares
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Type POINT
x As Long
y As Long
End Type
Private Type RGBColor
r As Single
G As Single
B As Single
End Type
'//Misc and multi-use declares
Private Const WM_NCACTIVATE As Long = &H86
Private Const WM_ACTIVATE As Long = &H6
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINT) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINT) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
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 Long) As Long
'//Button states
Private Enum enumStates
eDISABLE = 0
eIDLE = 1
eFOCUS = 2
eHOT = 3
eDOWN = 4
End Enum
Public Enum WindowState
InActive = 0
Active = 1
End Enum
'//Button colors
Private Type typeColors
cBorders(0 To 4) As Long
cTopLine1(0 To 4) As Long
cTopLine2(0 To 4) As Long
cBottomLine1(0 To 4) As Long
cBottomLine2(0 To 4) As Long
cCornerPixel1(0 To 4) As Long
cCornerPixel2(0 To 4) As Long
cCornerPixel3(0 To 4) As Long
cSideGradTop(1 To 3) As Long
cSideGradBottom(1 To 3) As Long
End Type
'//Public Events
Public Event Click()
Public Event DblClick()
Public Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Public Event FormActivate(State As WindowState)
'//Private variables
Private iDownButton As Integer '------- Down mouse button (for DblClick event)
Private bSkipDrawing As Boolean '------- Pauses drawing when needed
Private bButtonIsDown As Boolean '------- Tracks button down state
Private bHasFocus As Boolean '------- Tracks button focus state
Private bMouseInControl As Boolean '------- Tracks when mouse is in or out of the button
Private tColors As typeColors '---- Enum declare for typeColors
Private bParentActive As Boolean '------- Tracks when parent form has the Windows focus
Private bSpaceBarIsDown As Boolean '------- Tracks state of spacebar for KeyUp/Down events
Private bMouseButtonIsDown As Boolean '------- Tracks state of mousebutton for KeyUp/Down events
Private bDisplayAsDefault As Boolean '------- USed for ambient default property changes
Private lParentHwnd As Long '---------- Stores the parents window handle
Private eSTATE As enumStates '---- Enum declare for enumStates
'//Propbag variables
Private pHWND As Long
Private pCAPTION As String
Private pENABLED As Boolean
Private pFORECOLOR As OLE_COLOR
Private pFOCUSRECT As Boolean
Private WithEvents pFONT As StdFont
Attribute pFONT.VB_VarHelpID = -1
Private Sub DrawButton(ByVal State As enumStates)
On Error Resume Next
Dim lw As Long
Dim lh As Long
Dim lHdc As Long
Dim r As RECT
Dim hRgn As Long
If bSkipDrawing Then Exit Sub Else eSTATE = State '--------------------- Bolt if desired
With UserControl: lw = .ScaleWidth: lh = .ScaleHeight: .Cls: End With
Private Sub DrawFilled(tR As RECT, ByVal cBackColor As Long)
Dim hBrush As Long
hBrush = CreateSolidBrush(cBackColor) '----------------- Fill with solid brush
FillRect UserControl.hdc, tR, hBrush
DeleteObject hBrush
End Sub
Private Sub LineApi(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal Color As Long)
Dim pt As POINT
Dim hPen As Long
Dim hPenOld As Long
Dim lHdc As Long
lHdc = UserControl.hdc
hPen = CreatePen(0, 1, Color)
hPenOld = SelectObject(lHdc, hPen)
MoveToEx lHdc, X1, Y1, pt
LineTo lHdc, X2, Y2
SelectObject lHdc, hPenOld
DeleteObject hPen
End Sub
Private Sub FillColorScheme()
With tColors
.cBorders(0) = 12240841 '--------- Store Disabled Colors
.cTopLine1(0) = 15726583
.cTopLine2(0) = 15726583
.cCornerPixel1(0) = 9220548
.cCornerPixel2(0) = 12437454
.cCornerPixel3(0) = 9220548
.cBorders(1) = 7617536 '---------- Store Idle Colors
.cTopLine1(1) = 16777215
.cTopLine2(1) = 16711422
.cBottomLine1(1) = 14082018
.cBottomLine2(1) = 12964054
.cCornerPixel1(1) = 8672545
.cCornerPixel2(1) = 11376251
.cCornerPixel3(1) = 10845522
.cSideGradTop(1) = 16514300
.cSideGradBottom(1) = 15133676
.cBorders(2) = 7617536 '---------- Store Focus Colors
.cTopLine1(2) = 16771022
.cTopLine2(2) = 16242621
.cBottomLine1(2) = 15183500
.cBottomLine2(2) = 15696491
.cCornerPixel1(2) = 8672545
.cCornerPixel2(2) = 11376251
.cCornerPixel3(2) = 10845522
.cSideGradTop(2) = 16241597
.cSideGradBottom(2) = 15183500
.cBorders(3) = 7617536 '---------- Store Hot Colors
.cTopLine1(3) = 13562879
.cTopLine2(3) = 9231359
.cBottomLine1(3) = 3257087
.cBottomLine2(3) = 38630
.cCornerPixel1(3) = 8672545
.cCornerPixel2(3) = 11376251
.cCornerPixel3(3) = 10845522
.cSideGradTop(3) = 10280929
.cSideGradBottom(3) = 3192575
.cBorders(4) = 7617536 '---------- Store Down Colors.
.cTopLine1(4) = 14607335
.cTopLine2(4) = 14607335
.cBottomLine1(4) = 13289407
.cCornerPixel1(4) = 8672545
.cCornerPixel2(4) = 11376251
.cCornerPixel3(4) = 10845522
End With
End Sub
Private Function GetAccessKey() As String
'//Extracts and returns the AccessKey appropriate for passed caption
'..Function provided by LiTe Templer (Guenter Wirth)
Dim lPos As Long
Dim lLen As Long
Dim lSearch As Long
Dim sChr As String
lLen = Len(pCAPTION)
If lLen = 0 Then Exit Function
lPos = 1
Do While lPos + 1 < lLen
lSearch = InStr(lPos, pCAPTION, "&")
If lSearch = 0 Or lSearch = lLen Then Exit Do
sChr = LCase$(Mid$(pCAPTION, lSearch + 1, 1))
If sChr = "&" Then
lPos = lSearch + 2
Else
GetAccessKey = sChr
Exit Do
End If
Loop
End Function
Private Sub TrackMouseLeave(ByVal lng_hWnd As Long)
On Error GoTo Errs
Dim tme As TRACKMOUSEEVENT_STRUCT
With tme
.cbSize = Len(tme)
.dwFlags = TME_LEAVE
.hwndTrack = lng_hWnd
End With
Call TrackMouseEvent(tme) '---- Track the mouse leaving the indicated window via subclassing
Errs:
End Sub
'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)
Select Case uMsg
Case WM_MOUSELEAVE
bMouseInControl = False
If bSpaceBarIsDown Then Exit Sub
If eSTATE <> eDISABLE Then
If bHasFocus Or bDisplayAsDefault Then
If eSTATE = eDOWN Then
If bButtonIsDown Then
Call DrawButton(eFOCUS)
Else
If eSTATE <> eIDLE Then Call DrawButton(eIDLE)
End If
Else
If eSTATE <> eFOCUS Then
If bParentActive Then Call DrawButton(eFOCUS)
End If
End If
Else
If eSTATE <> eIDLE Then Call DrawButton(eIDLE)
End If
End If
Case WM_NCACTIVATE, WM_ACTIVATE
If wParam Then '----------------------------------- Activated
bParentActive = True
If pENABLED Then
If bMouseInControl Then
If eSTATE <> eHOT Then Call DrawButton(eHOT)
Else
If (bHasFocus Or bDisplayAsDefault) Then Call DrawButton(eFOCUS)
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 = 202 '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
'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.
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
Errs:
'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)
