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

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

 von ActiveVB

'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-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

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

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

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.

Dim MyButton As ODCBTYPE

MyButton.Refresh

MyButton.Width = MyButton.Width + 150

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