CodeItBetter Programming Another VB Programming Blog

'Controls - How to set the Command Button's caption color

Option Explicit
 
'Add a Command Button to your form. Set the Command Button style property to 1 - Graphical.

Private colButtons As New Collection
Private Const KeyConst = "K"
Private Const FormName = "ThunderFormDC"
Private Const PROP_COLOR = "SMDColor"
Private Const PROP_HWNDPARENT = "SMDhWndParent"
Private Const PROP_LPWNDPROC = "SMDlpWndProc"
Private Const GWL_WNDPROC = -4
Private Const ODA_SELECT = &H2
Private Const ODS_SELECTED = &H1
Private Const ODS_FOCUS = &H10
Private Const ODS_BUTTONDOWN = ODS_FOCUS + ODS_SELECTED
Private Const WM_DESTROY = &H2
Private Const WM_DRAWITEM = &H2B
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type Size
    cx As Long
    cy As Long
End Type
Private Type DRAWITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemAction As Long
    itemState As Long
    hWndItem As Long
    hDC As Long
    rcItem As RECT
    itemData As Long
End Type
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
    ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, lParam As DRAWITEMSTRUCT) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, _
    ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, _
    ByVal lpString As String) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" _
    (ByVal hDC As Long, ByVal lpSz As String, ByVal cbString As Long, lpSize As Size) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, _
    ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, _
    ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, _
    ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, _
    ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
 
Private Function FindButton(sKey As String) As Boolean
    Dim cmdButton As CommandButton
    On Error Resume Next
    Set cmdButton = colButtons.Item(sKey)
    FindButton = (Err.Number = 0)
End Function
 
Private Function GetFormHandle(hWndButton As Long) As Long
    Dim hWndParent As Long, l As Long
    Dim ClassName As String * 128
    hWndParent = GetParent(hWndButton)
    Do Until (hWndParent = 0)
        l = GetClassName(hWndParent, ClassName, Len(ClassName))
        If Left(ClassName, l) = FormName Then Exit Do
        hWndParent = GetParent(hWndParent)
    Loop
    GetFormHandle = hWndParent
End Function
 
Private Function GetKey(hWnd As Long) As String
    GetKey = KeyConst & hWnd
End Function
 
Private Function ProcessButton(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, _
    lParam As DRAWITEMSTRUCT, sKey As String) As Long
    Dim cmdButton As CommandButton
    Dim bRC As Boolean
    Dim lRC As Long
    Dim x As Long
    Dim y As Long
    Dim lpWndProc As Long
    Dim lButtonWidth As Long
    Dim lButtonHeight As Long
    Dim lPrevColor As Long
    Dim lColor As Long
    Dim TextSize As Size
    Dim sCaption As String
    Const PushOffset = 2
    Set cmdButton = colButtons.Item(sKey)
    sCaption = cmdButton.Caption
    lColor = GetProp(cmdButton.hWnd, PROP_COLOR)
    lPrevColor = SetTextColor(lParam.hDC, lColor)
    lRC = GetTextExtentPoint32(lParam.hDC, sCaption, Len(sCaption), TextSize)
    lButtonHeight = lParam.rcItem.Bottom - lParam.rcItem.Top
    lButtonWidth = lParam.rcItem.Right - lParam.rcItem.Left
    If (lParam.itemAction = ODA_SELECT) And (lParam.itemState = ODS_BUTTONDOWN) Then
        cmdButton.SetFocus
        DoEvents
        x = (lButtonWidth - TextSize.cx + PushOffset) \ 2
        y = (lButtonHeight - TextSize.cy + PushOffset) \ 2
    Else
        x = (lButtonWidth - TextSize.cx) \ 2
        y = (lButtonHeight - TextSize.cy) \ 2
    End If
    lpWndProc = GetProp(hWnd, PROP_LPWNDPROC)
    ProcessButton = CallWindowProc(lpWndProc, hWnd, uMsg, wParam, lParam)
    bRC = TextOut(lParam.hDC, x, y, sCaption, Len(sCaption))
    lRC = SetTextColor(lParam.hDC, lPrevColor)
ProcessButton_Exit:
    Set cmdButton = Nothing
End Function
 
Private Sub RemoveForm(hWndParent As Long)
    Dim hWndButton As Long, I As Integer
    UnsubclassForm hWndParent
    On Error GoTo RemoveForm_Exit
    For I = colButtons.Count - 1 To 0 Step -1
        hWndButton = colButtons(I).hWnd
        If GetProp(hWndButton, PROP_HWNDPARENT) = hWndParent Then
            RemoveProp hWndButton, PROP_COLOR
            RemoveProp hWndButton, PROP_HWNDPARENT
            colButtons.Remove I
        End If
    Next I
 
RemoveForm_Exit:
    Exit Sub
End Sub
 
Private Function UnsubclassForm(hWnd As Long) As Boolean
    Dim lRC As Long, lpWndProc As Long
    lpWndProc = GetProp(hWnd, PROP_LPWNDPROC)
    If lpWndProc = 0 Then
        UnsubclassForm = False
    Else
        lRC = SetWindowLong(hWnd, GWL_WNDPROC, lpWndProc)
        RemoveProp hWnd, PROP_LPWNDPROC
        UnsubclassForm = True
    End If
End Function
 
Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, _
    lParam As DRAWITEMSTRUCT) As Long
    Dim lpWndProc As Long
    Dim bProcessButton As Boolean
    Dim sButtonKey As String
    bProcessButton = False
    If (uMsg = WM_DRAWITEM) Then
        sButtonKey = GetKey(lParam.hWndItem)
        bProcessButton = FindButton(sButtonKey)
    End If
    If bProcessButton Then
        ProcessButton hWnd, uMsg, wParam, lParam, sButtonKey
    Else
        lpWndProc = GetProp(hWnd, PROP_LPWNDPROC)
        WindowProc = CallWindowProc(lpWndProc, hWnd, uMsg, wParam, lParam)
        If uMsg = WM_DESTROY Then RemoveForm hWnd
    End If
End Function
 
Public Function RegisterButton(Button As CommandButton, Forecolor As Long)
    Dim hWndParent As Long, lpWndProc As Long
    Dim sButtonKey As String
    sButtonKey = GetKey(Button.hWnd)
    If FindButton(sButtonKey) Then
        SetProp Button.hWnd, PROP_COLOR, Forecolor
        Button.Refresh
    Else
        hWndParent = GetFormHandle(Button.hWnd)
        If (hWndParent = 0) Then
            RegisterButton = False
            Exit Function
        End If
        colButtons.Add Button, sButtonKey
        SetProp Button.hWnd, PROP_COLOR, Forecolor
        SetProp Button.hWnd, PROP_HWNDPARENT, hWndParent
        lpWndProc = GetProp(hWndParent, PROP_LPWNDPROC)
        If (lpWndProc = 0) Then
            lpWndProc = SetWindowLong(hWndParent, _
                                      GWL_WNDPROC, AddressOf WindowProc)
            SetProp hWndParent, PROP_LPWNDPROC, lpWndProc
        End If
    End If
    RegisterButton = True
End Function
 
Public Function UnregisterButton(Button As CommandButton) As Boolean
    Dim hWndParent As Long
    Dim sKeyButton As String
    sKeyButton = GetKey(Button.hWnd)
    If (FindButton(sKeyButton) = False) Then
        UnregisterButton = False
        Exit Function
    End If
    hWndParent = GetProp(Button.hWnd, PROP_HWNDPARENT)
    UnregisterButton = UnsubclassForm(hWndParent)
    colButtons.Remove sKeyButton
    RemoveProp Button.hWnd, PROP_COLOR
    RemoveProp Button.hWnd, PROP_HWNDPARENT
End Function
 
'Add the following code to your form:

Private Sub Form_Load()
    'Replace 'Command1' with the name of your Command Button,
    'Replace 'vbRed' with the caption color. You can put here the Hex value of the color.
    RegisterButton Command1, vbRed
End Sub