Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0326: ForeColor eines CommandButtons beliebig setzen, ownerdrawn

 von 

Beschreibung 

Auch CommandButtons können OwnerDrawn sein. VB bietet z.B. standardmäßig nicht die Möglichkeit die Schriftfarbe der Caption eines Buttons zu ändern. Ob der hiesige Aufwand für ein solches Gimmick gerechtfertigt ist, ist natürlich streitbar. Muß man sich doch bei einer solchen Vorgehensweise um jede Kleinigkeit wie auch das Eventhandling kümmern, eigentlich ist der CommandButton komplett neu zu schreiben.

Schwierigkeitsgrad:

Schwierigkeitsgrad 3

Verwendete API-Aufrufe:

CallWindowProcA (CallWindowProc), RtlMoveMemory (CopyMemory), CreateSolidBrush, CreateWindowExA (CreateWindowEx), DeleteObject, DestroyWindow, DrawEdge, DrawFocusRect, DrawTextExA (DrawTextEx), FillRect, InflateRect, OffsetRect, SelectObject, SendMessageA (SendMessage), SetBkColor, SetTextColor, SetWindowLongA (SetWindowLong)

Download:

Download des Beispielprojektes [4,29 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 Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------

Option Explicit

Private Sub Form_Load()
  Call InitButton(Me, RGB(255, 0, 0), RGB(0, 0, 255))
End Sub

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

Option Explicit

Private Declare Function CreateWindowEx Lib "user32" Alias _
        "CreateWindowExA" (ByVal dwExStyle As Long, ByVal _
        lpClassName As String, ByVal lpWindowName As String, _
        ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, _
        ByVal nWidth As Long, ByVal nHeight As Long, ByVal _
        hwndParent As Long, ByVal hMenu As Long, ByVal hInstance _
        As Long, lpParam As Any) As Long

Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd _
        As Long) As Long

Private Declare Function CallWindowProc Lib "user32" Alias _
        "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal _
        hWnd As Long, ByVal MSG As Long, ByVal wParam As _
        Long, ByVal lParam 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 SendMessage Lib "user32" Alias _
        "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
        ByVal wParam As Long, lParam As Any) As Long

Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
        (lpDest As Any, lpSource As Any, ByVal nCount As Long)
        
Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, _
        qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) _
        As Long

Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, _
        lpRect As RECT) As Long

Private Declare Function InflateRect Lib "user32" (lpRect As RECT, _
        ByVal X As Long, ByVal Y 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 OffsetRect Lib "user32" (lpRect As RECT, _
        ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" _
        (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, _
        lpRect As RECT, ByVal un As Long, lpDrawTextParams As Any) _
        As Long

Private Declare Function CreateSolidBrush Lib "gdi32" (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 SetBkColor Lib "gdi32" (ByVal hDC As Long, _
        ByVal crColor As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, _
        ByVal crColor As Long) As Long
        
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom 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 Type DRAWTEXTPARAMS
  cbSize As Long
  iTabLength As Long
  iLeftMargin As Long
  iRightMargin As Long
  uiLengthDrawn As Long
End Type

Const GWL_WNDPROC = (-4&)

Const WM_GETFONT = &H31
Const WM_DRAWITEM = &H2B
Const WM_COMMAND = &H111

Const WS_CHILD = &H40000000
Const WS_VISIBLE = &H10000000

Const ODS_FOCUS = &H10
Const ODS_SELECTED = &H1

Const BS_PUSHBUTTON = &H0&
Const BS_OWNERDRAW = &HB&

Const BF_LEFT = &H1
Const BF_TOP = &H2
Const BF_RIGHT = &H4
Const BF_BOTTOM = &H8
Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)

Const BDR_RAISEDOUTER = &H1
Const BDR_SUNKENOUTER = &H2
Const BDR_RAISEDINNER = &H4
Const BDR_SUNKENINNER = &H8
Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)

Const DT_CENTER = &H1
Const DT_VCENTER = &H4
Const DT_SINGLELINE = &H20

Private Type ODCBTYPE
  Forecolor As Long
  Backcolor As Long
  Caption As String
  Picture As PictureBox
  hWnd As Long
  Left As Long
  Top  As Long
  Width As Long
  Height As Long
  Parent As Form
End Type

Dim MyButton As ODCBTYPE

Dim PrevWndProc&

'Subclassing initieren
Private Sub SubClass(hWnd&)
  PrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WndProc)
End Sub

'Subclassing Auflösen
Private Sub UnSubClass(hWnd&)
  Call SetWindowLong(hWnd, GWL_WNDPROC, PrevWndProc)
End Sub

'Subclassing Routine des Forms für die ReDrawereignisse
Private Function WndProc(ByVal hWnd As Long, ByVal MSG As Long, _
                         ByVal wParam As Long, ByVal lParam As _
                         Long) As Long
                
  Select Case MSG
    Case WM_DRAWITEM: DrawButton (lParam)
                      WndProc = 1
    Case WM_COMMAND:
                      If lParam = MyButton.hWnd Then
                        MsgBox "Jepp"
                      End If
                      WndProc = 0
                      
    Case Else:        WndProc = CallWindowProc(PrevWndProc, _
                                               hWnd, MSG, _
                                               wParam, _
                                               lParam)
  End Select
End Function

'Erstellen des neuen Buttons
Public Sub InitButton(F As Form, BCol&, FCol&)
  Dim BStyle&
  Dim hFont As Long

    With MyButton
      Set .Parent = F
      
      .Top = 6
      .Left = 6
      .Width = 170
      .Height = 40
      .Forecolor = FCol
      .Backcolor = BCol
      .Caption = "MyCommandButton"
      
      BStyle = BS_PUSHBUTTON Or BS_OWNERDRAW Or _
               WS_CHILD Or WS_VISIBLE
      .hWnd = CreateWindowEx(0&, "BUTTON", vbNullString, BStyle, _
                             .Left, .Top, .Width, .Height, _
                             .Parent.hWnd, 0&, App.hInstance, _
                             ByVal 0&)
      Call SubClass(.Parent.hWnd)
    End With

End Sub

'Löschen des Buttons
Public Sub ExitButton()
  Call DestroyWindow(MyButton.hWnd)
  UnSubClass (MyButton.Parent.hWnd)
End Sub

'Zeichnen des Buttons
Public Sub DrawButton(lParam As Long)
  Dim DI As DRAWITEMSTRUCT, DTP As DRAWTEXTPARAMS, FR As RECT
  Dim FColor&, BColor&, hFont&, hMemFont&, hBrush
  Static GotFocus As Boolean
  
    Call CopyMemory(DI, ByVal lParam, Len(DI))
    
    With DI
      BColor = SetBkColor(.hDC, MyButton.Backcolor)
      hBrush = CreateSolidBrush(MyButton.Backcolor)
      FColor = SetTextColor(.hDC, MyButton.Forecolor)

      FR = .rcItem
      With FR
        .Left = .Left + 5
        .Top = .Top + 5
        .Right = .Right - 5
        .Bottom = .Bottom - 5
      End With
      
      If (.itemState And ODS_SELECTED) Then
        Call DrawEdge(.hDC, .rcItem, EDGE_SUNKEN, BF_RECT)
      Else
        Call DrawEdge(.hDC, .rcItem, EDGE_RAISED, BF_RECT)
      End If

      Call InflateRect(.rcItem, -2, -2)
      Call FillRect(.hDC, .rcItem, hBrush)
      If (.itemState And ODS_SELECTED) Then
        Call OffsetRect(.rcItem, 1&, 1&)
      End If
      
      hFont = SendMessage(MyButton.Parent.hWnd, _
                          WM_GETFONT, 0, ByVal 0&)
                          
      hMemFont = SelectObject(.hDC, hFont)
      DTP.cbSize = Len(DTP)
      Call DrawTextEx(.hDC, MyButton.Caption, Len(MyButton.Caption), _
                      .rcItem, DT_CENTER Or DT_VCENTER Or _
                      DT_SINGLELINE, DTP)

      If (.itemState And ODS_FOCUS) Then
        Call DrawFocusRect(.hDC, FR)
        GotFocus = True
      Else
        If GotFocus Then
          Call DrawFocusRect(.hDC, FR)
          GotFocus = False
        End If
      End If
  
      Call DeleteObject(hBrush)
      Call SetBkColor(.hDC, BColor)
      Call SetTextColor(.hDC, FColor)
      Call SelectObject(.hDC, hMemFont)
      Call DeleteObject(hFont)
    End With
    
    Call CopyMemory(ByVal lParam, DI, Len(DI))
End Sub
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 6 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Kommentar von Alf am 12.11.2005 um 17:07

Ich habe die Twips bereits nach deiner ersten Antwort mit 15 multipliziert.

Du gehst davon aus, "MyButton" sei als "Command" deklariert?
Dann schau die Deklaration mal genau an:

Dim MyButton As ODCBTYPE

Und da gibt es offensichtlich keine "Refresh"-Methode!

Kommentar von KlausM am 12.11.2005 um 16:23

An sich zeichnet sich der Button nach Ändern der Breite von allein neu, nur bei 10 Twips sieht man das nicht.

Willst du den Button dennoch extra neuzeichnen:

MyButton.Refresh

Kommentar von Alf am 12.11.2005 um 15:33

Ok, danke für den Tipp.
Die Kernfrage bleibt jedoch die gleiche: Wie wird der Button neu gezeichnet?
Welchen Befehl verwende ich dazu?
Geht dies evtl. mit "SendMessage"?

Kommentar von KlausM am 12.11.2005 um 14:38

Die Bildschirm-Einheit wird nicht in Pixeln sondern in Twips gemessen. Standardmäßig sind 15 Twips 1 Pixel. Daher solltest du vielleicht schreiben:

MyButton.Width = MyButton.Width + 150

Kommentar von Alf am 12.11.2005 um 13:50

Dieser Tip war für mich sehr hilfreich.

Ich hätte noch eine weiterführende Frage:
Wie lässt sich z.B. die Breite des Buttons zur Laufzeit ändern? Ich habe noch einen zusätzlichen VB-CommandButton
aufs Formular gesetzt:

Private Sub Command1_Click   
MyButton.Width = MyButton.Width + 10
'Was für ein Befehl muss nun stehen, damit
'der Button über WndPrc/DrawButton neu
'gezeichnet werden kann???
End Sub

Kommentar von Markus am 20.05.2002 um 14:34

Spitze Tip! Muss man echt sagen.
Doch für mich ein bisschen umständlich!
Ich bevorzuge die Microsoft Forms 2.0! (Bei VB6 als FM20.dll enthalten.)
Mit den Steuerelementen dieser Libary kann man mehr anfangen, als mit den Standardsteuerelementen! Zum Beispiel auch die ForeColor eines CommandButtons verändern. *g*
ZeeYaa
Markus