isbutton.ctl

simple supermarket for beginners

                             ByVal Y1 As Long, _
                             ByVal X2 As Long, _
                             ByVal Y2 As Long) As Long
Private Declare Function SetParent _
                Lib "user32.dll" (ByVal hWndChild As Long, _
                                  ByVal hWndNewParent As Long) As Long
Private Declare Function CreateIconIndirect _
                Lib "User32" (piconinfo As ICONINFO) As Long
Private Declare Function ReleaseDC _
                Lib "User32" (ByVal hwnd As Long, _
                              ByVal hdc As Long) As Long
Private Declare Function DrawIconEx _
                Lib "User32" (ByVal hdc As Long, _
                              ByVal xLeft As Long, _
                              ByVal yTop As Long, _
                              ByVal hIcon As Long, _
                              ByVal cxWidth As Long, _
                              ByVal cyWidth As Long, _
                              ByVal istepIfAniCur As Long, _
                              ByVal hbrFlickerFreeDraw As Long, _
                              ByVal diFlags As Long) As Long
Private Declare Function DestroyIcon _
                Lib "user32.dll" (ByVal hIcon As Long) As Long
Private Declare Function GetIconInfo _
                Lib "user32.dll" (ByVal hIcon As Long, _
                                  ByRef piconinfo As ICONINFO) As Long
Private Declare Function GetObjectAPI _
                Lib "gdi32" _
                Alias "GetObjectA" (ByVal hObject As Long, _
                                    ByVal nCount As Long, _
                                    lpObject As Any) As Long
Private Declare Function GetDIBits _
                Lib "gdi32" (ByVal aHDC As Long, _
                            ByVal hBitmap As Long, _
                            ByVal nStartScan As Long, _
                            ByVal nNumScans As Long, _
                            lpBits As Any, _
                            lpBI As BITMAPINFO, _
                            ByVal wUsage As Long) As Long
Private Declare Function GetNearestColor _
                Lib "gdi32" (ByVal hdc As Long, _
                            ByVal crColor As Long) As Long
Private Declare Function SetDIBitsToDevice _
                Lib "gdi32" (ByVal hdc As Long, _
                            ByVal X As Long, _
                            ByVal Y As Long, _
                            ByVal dx As Long, _
                            ByVal dy As Long, _
                            ByVal SrcX As Long, _
                            ByVal SrcY As Long, _
                            ByVal Scan As Long, _
                            ByVal NumScans As Long, _
                            Bits As Any, _
                            BitsInfo As BITMAPINFO, _
                            ByVal wUsage As Long) As Long

'*************************************************************
'
'   Private variables
'
'*************************************************************
Private m_bFocused                  As Boolean
Private m_bVisible                   As Boolean
Private m_iState                    As isState
Private m_iStyle                    As isbStyle
Private m_iNonThemeStyle            As isbStyle
Private m_btnRect                   As RECT
Private m_txtRect                   As RECT
Private m_lRegion                   As Long
Private m_sCaption                  As String
Private m_CaptionAlign              As isbAlign
Private m_IconAlign                 As isbAlign
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 m_MaskColor                 As Long
Private m_UseMaskColor              As Boolean
Private m_bRoundedBordersByTheme    As Boolean
Private m_bRTLText                   As Long
Private lPrevStyle                  As Long
Private iStyleIconOffset            As Long

'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 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
  On Error GoTo zSubclass_Proc_Error

  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
      RemoveToolTip
      Refresh
      RaiseEvent MouseLeave
    Case WM_SYSCOLORCHANGE
      Refresh
    Case WM_THEMECHANGED
      Refresh
  End Select

  Exit Sub

zSubclass_Proc_Error:
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)
  On Error GoTo Subclass_AddMsg_Error

  '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

  Exit Sub

Subclass_AddMsg_Error:
End Sub

'Return whether we're running in the IDE.
Private Function Subclass_InIDE() As Boolean
  On Error GoTo Subclass_InIDE_Error

  Debug.Assert zSetTrue(Subclass_InIDE)
  Exit Function

Subclass_InIDE_Error:
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
  On Error GoTo Subclass_Start_Error

  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

  Exit Function

Subclass_Start_Error:
End Function

'Stop all subclassing
Private Sub Subclass_StopAll()
  On Error GoTo Subclass_StopAll_Error

  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

  Exit Sub

Subclass_StopAll_Error:
End Sub

'Stop subclassing the passed window handle
Private Sub Subclass_Stop(ByVal lng_hWnd As Long)
  On Error GoTo Subclass_Stop_Error

  '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

  Exit Sub