Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0588: ForeColor eines CommandButtons beliebig setzen II

VB 5/6-Tipp 0588: ForeColor eines CommandButtons beliebig setzen II

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CallWindowProcA (CallWindowProc), GetParent, GetPropA (GetProp), GetTextExtentPoint32A (GetTextExtentPoint32), RemovePropA (RemoveProp), SetPropA (SetProp), SetTextColor, SetWindowLongA (SetWindowLong), TextOutA (TextOut)

Download: Download des Beispielprojektes [4,38 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command1"

Option Explicit

Private Sub Form_Load()
    'Command1.Style = 1 auf Grafisch
    'Dem Bunten Button erstellen
    RegisterButton Command1, vbRed
End Sub

Private Sub Form_Unload(Cancel As Integer)
    UnregisterButton Command1
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------

Option Explicit

Private colButtons  As New Collection
Private Const KeyConst = "K"
Private Const PROP_COLOR = "SMDColor"
Private Const PROP_HWNDPARENT = "SMDhWndParent"
Private Const PROP_LPWNDPROC = "SMDlpWndProc"
Private Const GWL_WNDPROC As Long = (-4)
Private Const ODA_SELECT As Long = &H2
Private Const ODS_SELECTED As Long = &H1
Private Const ODS_FOCUS As Long = &H10
Private Const ODS_BUTTONDOWN As Long = ODS_FOCUS Or ODS_SELECTED
Private Const WM_DESTROY As Long = &H2
Private Const WM_DRAWITEM As Long = &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 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 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 Command1Button As CommandButton
  
  On Error Resume Next
  Set Command1Button = colButtons.Item(sKey)
  FindButton = (Err.Number = 0)
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 Command1Button  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 Command1Button = colButtons.Item(sKey)
  sCaption = Command1Button.Caption
  
  lColor = GetProp(Command1Button.hWnd, PROP_COLOR)
  lPrevColor = SetTextColor(lParam.hDC, lColor)
  
  'In Pixeln/Logical Units
  lRC = GetTextExtentPoint32(lParam.hDC, _
  sCaption, Len(sCaption), TextSize)
  
  'In Pixeln/Logical Units
  lButtonHeight = lParam.rcItem.Bottom - lParam.rcItem.Top
  lButtonWidth = lParam.rcItem.Right - lParam.rcItem.Left
  
  'Der Button ist gedrückt. Den Text verschieben, dass
  'es so aussieht, als sei er gedrückt.
  If (lParam.itemAction = ODA_SELECT) And _
    (lParam.itemState = ODS_BUTTONDOWN) Then
    Command1Button.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
  
  'Die Standard WndProd address auslesen
  lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)
  
  'Die Standard Routine starten
  ProcessButton = CallWindowProc(lpWndProC, hWnd, uMsg, wParam, lParam)
  
  'Den Text auf das Button schreiben
  bRC = TextOut(lParam.hDC, X, Y, sCaption, Len(sCaption))
  
  'Auf die originalfarbe zurücksetzen
  lRC = SetTextColor(lParam.hDC, lPrevColor)
  
ProcessButton_Exit:
  Set Command1Button = Nothing
End Function


Private Sub RemoveForm(hWndParent As Long)
  Dim hWndButton As Long
  Dim 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 lpWndProC As Long
  
  lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)
  
  If lpWndProC = 0 Then
    UnsubclassForm = False
  Else
    Call SetWindowLong(hWnd, GWL_WNDPROC, lpWndProC)
    RemoveProp hWnd, PROP_LPWNDPROC
    UnsubclassForm = True
  End If
End Function


Private Function ButtonColorProc(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
  
  'Wenn gezeichnet werden soll
  If (uMsg = WM_DRAWITEM) Then
    
    'Haben wir den Button? Um es herauszufinden,
    'dereferenzieren wir das Item in der Collection.
    'Wenn es dabei ist, haben wir ihn. Wenn nicht,
    'erhalten wir einen Fehler
    sButtonKey = GetKey(lParam.hWndItem)
    bProcessButton = FindButton(sButtonKey)
  
  End If
  
  
  If bProcessButton Then
    ProcessButton hWnd, uMsg, wParam, lParam, sButtonKey
  Else
    lpWndProC = GetProp(hWnd, PROP_LPWNDPROC)
    ButtonColorProc = 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) As Boolean

  Dim hWndParent    As Long
  Dim lpWndProC     As Long
  Dim sButtonKey    As String
  
  'Den Colorkey für den Button erstellen
  sButtonKey = GetKey(Button.hWnd)
  
  'Wenn wir den Button bereits besitzen, einfach nur
  'die Farbe ändern. Ansonsten müssen wir alles machen.
  
  If FindButton(sButtonKey) Then
    SetProp Button.hWnd, PROP_COLOR, Forecolor
    Button.Refresh
  Else
    
    'Das Handle des Parents Auslesen
    hWndParent = GetParent(Button.hWnd)
    
    'Wenn wir kein Parent finden, Fehler ausgeben
    If (hWndParent = 0) Then
      RegisterButton = False
      Exit Function
    End If
    
    'Das Parent wurde gefunden. Alle nötigen Informationen
    'sammeln und speichern.
    
    colButtons.Add Button, sButtonKey
    SetProp Button.hWnd, PROP_COLOR, Forecolor
    SetProp Button.hWnd, PROP_HWNDPARENT, hWndParent
    
    'Feststellen, ob wir das Form bereits subclassen.
    lpWndProC = GetProp(hWndParent, PROP_LPWNDPROC)
    
    'Es ist ein neues Form. Subclassen und Window proc Adresse
    'in der Collection speichern.
    
    If (lpWndProC = 0) Then
      lpWndProC = SetWindowLong(hWndParent, _
      GWL_WNDPROC, AddressOf ButtonColorProc)
      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

'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------