Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0766: Hintergrundfarbe von Scrollbar-Steuerelementen ändern

VB 5/6-Tipp 0766: Hintergrundfarbe von Scrollbar-Steuerelementen ändern

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CallWindowProcA (CallWindowProc), CreateSolidBrush, DeleteObject, OleTranslateColor, SetWindowLongA (SetWindowLong)

Download: Download des Beispielprojektes [4.71 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 ColorScrollBar.vbp ----------
'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Schaltfläche "cmdAdd"
' Steuerelement: Schaltfläche "cmdRemove"
' Steuerelement: Bildfeld-Steuerelement "picRGB"
' Steuerelement: Horizontale Scrollbar "hsRGB" (Index von 0 bis 3)
' Steuerelement: Beschriftungsfeld "lblRGB" (Index von 0 bis 3)
Option Explicit

Private Sub cmdAdd_Click()

    ' Scrollbar der Subclassingroutine hinzufügen
    Call AddScrollBar(hsRGB(1), vbGreen)
    
    ' Buttons entsprechend aktivieren oder deaktivieren
    cmdAdd.Enabled = False
    cmdRemove.Enabled = True
    
End Sub

Private Sub cmdRemove_Click()

    ' Scrollbar von der Subclassingroutine entfernen
    Call RemoveScrollBar(hsRGB(1))
    
    ' Buttons entsprechend aktivieren oder deaktivieren
    cmdAdd.Enabled = True
    cmdRemove.Enabled = False
    
End Sub

Private Sub Form_Load()

    Dim lngItem As Long
    
    ' Hintergrundfarbe der PictureBox setzen
    picRGB.BackColor = vbBlack
    
    ' Button deaktivieren
    cmdAdd.Enabled = False
    
    ' alle ScrollBar-Elemente durchlaufen
    For lngItem = 0 To hsRGB.Count - 1
    
        Select Case lngItem
        
        Case 0, 1, 2 ' ScrollBar mit dem Index 0, 1 und 2
            hsRGB(lngItem).Max = 255
            lblRGB(lngItem).Caption = "0"
            
        Case 3 ' ScrollBar mit dem Index 3
            hsRGB(lngItem).Max = 15
            lblRGB(lngItem).Caption = "QBColor(0)"
            
        End Select
        
    Next lngItem
    
    ' ScrollBars der Subclassingroutine hinzufügen. Es können auch
    ' nach dem Start des Subclassing ScrollBars hinzugefügt werden.
    ' Aufruf: Call AddScrollBar(ScrollBar, Hintergrundfarbe)
    Call AddScrollBar(hsRGB(0), vbRed)
    Call AddScrollBar(hsRGB(1), vbGreen)
    Call AddScrollBar(hsRGB(2), vbBlue)
    Call AddScrollBar(hsRGB(3), vbBlack)
    
    ' Subclassing der Form starten
    Call Hook(Me)
    
End Sub

Private Sub Form_Unload(Cancel As Integer)

    ' Subclassing der Form beenden
    Call Unhook
    
End Sub

Private Sub hsRGB_Change(Index As Integer)

    ' nach Index selektieren
    Select Case Index
    
    Case 0, 1, 2
    
        ' Text im Label setzen
        lblRGB(Index).Caption = CStr(hsRGB(Index).Value)
        
        ' Hintergrundfarbe der PictureBox setzen
        picRGB.BackColor = RGB(hsRGB(0).Value, hsRGB(1).Value, hsRGB(2).Value)
        
    Case 3
    
        ' Text im Label setzen
        lblRGB(Index).Caption = "QBColor(" & CStr(hsRGB(Index).Value) & ")"
        
        ' neue Hintergrundfarbe für diese ScrollBar setzen
        ' Aufruf: Call ChangeBackColor(ScrollBar, neue Hintergrundfarbe)
        Call ChangeBackColor(hsRGB(Index), QBColor(hsRGB(Index).Value))
        
    End Select
    
End Sub

Private Sub hsRGB_Scroll(Index As Integer)

    Call hsRGB_Change(Index)
    
End Sub
'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'------ Anfang Modul "modColorSB" alias modColorSB.bas ------
Option Explicit

' ---=== Const ===---
Private Const S_OK As Long = 0
Private Const GWL_WNDPROC As Long = -4
Private Const WM_CTLCOLORSCROLLBAR As Long = &H137

' ---=== Type ===---
Private Type ColorSB
    ScrollBar As Control
    hBrush As Long
End Type

' ---=== GDI32 Deklarationen ===---
Private Declare Function CreateSolidBrush Lib "gdi32" ( _
                         ByVal crColor As Long) As Long
                         
Private Declare Function DeleteObject Lib "gdi32" ( _
                         ByVal hObject As Long) As Long
                         
' ---=== USER32 Deklarationen ===---
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
                         
' ---=== OLEOUT32 Deklarationen ===---
Private Declare Function OleTranslateColor Lib "oleaut32" ( _
                         ByVal lOleColor As Long, _
                         ByVal lHPalette As Long, _
                         ByRef lColorRef As Long) As Long
                         
' ---=== Variablen ===---
Private lngCount As Long
Private hFrmHwnd As Long
Private lngOldWndProc As Long
Private tColorSB() As ColorSB

Public Sub AddScrollBar(ByRef ScrollBar As Control, ByVal BackColor As Long)

    Dim lngItem As Long
    Dim bolAddItem As Boolean
    
    bolAddItem = True
    
    ' ist es eine horizontale oder vertikale Scrollbar
    If TypeOf ScrollBar Is HScrollBar Or TypeOf ScrollBar Is VScrollBar Then
    
        ' alle Element im Array tColorSB durchlaufen
        For lngItem = 0 To lngCount - 1
        
            ' ist eine Scrollbar gespeichert
            If Not tColorSB(lngItem).ScrollBar Is Nothing Then
            
                ' sind die Fensterhandle der Scrollbars gleich
                If tColorSB(lngItem).ScrollBar.hWnd = ScrollBar.hWnd Then
                
                    ' merken das diese Scrollbar schon existiert
                    bolAddItem = False
                    
                    ' Schleife verlassen
                    Exit For
                    
                End If
            End If
            
        Next lngItem
        
        ' wenn die Scrollbar noch nicht im Array existiert
        If bolAddItem Then
        
            ' Systemfarben konvertieren
            If OleTranslateColor(BackColor, 0&, BackColor) = S_OK Then
            
                ' Array tColorSB redimensionieren
                ReDim Preserve tColorSB(lngCount)
                
                ' Scrollbar speichern
                Set tColorSB(lngCount).ScrollBar = ScrollBar
                
                ' Brush für diese Scrollbar erstellen
                tColorSB(lngCount).hBrush = CreateSolidBrush(BackColor)
                
                ' Anstelle von CreateSolidBrush kann auch jede andere Brush-API
                ' verwendet werden. So könnte man zb. mit CreatePatternBrush
                ' eine Bitmap als Hintergrund in eine Scrollbar setzen
                
                ' Zähler erhöhen
                lngCount = lngCount + 1
                
                ' erneutes zeichnen für diese Scrollbar anfordern
                tColorSB(lngCount - 1).ScrollBar.Refresh
                
            End If
        End If
    End If
    
End Sub

Public Sub RemoveScrollBar(ByRef ScrollBar As Control)

    Dim lngItem As Long
    Dim bolRemoveItem As Boolean
    
    bolRemoveItem = False
    
    ' ist es eine horizontale oder vertikale Scrollbar
    If TypeOf ScrollBar Is HScrollBar Or TypeOf ScrollBar Is VScrollBar Then
    
        ' alle Element im Array tColorSB durchlaufen
        For lngItem = 0 To lngCount - 1
        
            ' ist eine Scrollbar gespeichert
            If Not tColorSB(lngItem).ScrollBar Is Nothing Then
            
                ' sind die Fensterhandle der Scrollbars gleich
                If tColorSB(lngItem).ScrollBar.hWnd = ScrollBar.hWnd Then
                
                    ' merken das ab diesem Index umkopiert werden soll
                    bolRemoveItem = True
                    
                    ' gespeicherte Scrollbar löschen
                    Set tColorSB(lngItem).ScrollBar = Nothing
                    
                    ' ist ein Brush für diese Scrollbar vorhanden
                    If tColorSB(lngItem).hBrush <> 0 Then
                    
                        ' Brush löschen
                        Call DeleteObject(tColorSB(lngItem).hBrush)
                        
                    End If
                    
                Else
                
                    ' wurde eine Scrollbar entfernt
                    If bolRemoveItem Then
                    
                        ' nächste Scrollbar an die freie Stelle umkopieren
                        Set tColorSB(lngItem - 1).ScrollBar = tColorSB(lngItem).ScrollBar
                        
                        ' gespeicherte Scrollbar löschen
                        Set tColorSB(lngItem).ScrollBar = Nothing
                        
                        ' ist ein Brush für diese Scrollbar vorhanden
                        If tColorSB(lngItem).hBrush <> 0 Then
                        
                            ' Brusch an die freie Stelle umkopieren
                            tColorSB(lngItem - 1).hBrush = tColorSB(lngItem).hBrush
                            
                        End If
                    End If
                End If
            End If
            
        Next lngItem
        
        ' wurde eine Scrollbar entfernt
        If bolRemoveItem Then
        
            ' Zähler verkleinern
            lngCount = lngCount - 1
            
            ' Array tColorSB redimensionieren
            ReDim Preserve tColorSB(lngCount - 1)
            
            ' erneutes zeichnen für die entfernte Scrollbar anfordern
            ScrollBar.Refresh
            
        End If
    End If
    
End Sub

Public Sub ChangeBackColor(ByRef ScrollBar As Control, ByVal BackColor As Long)

    Dim lngItem As Long
    
    ' ist es eine horizontale oder vertikale Scrollbar
    If TypeOf ScrollBar Is HScrollBar Or TypeOf ScrollBar Is VScrollBar Then
    
        ' alle Element im Array tColorSB durchlaufen
        For lngItem = 0 To lngCount - 1
        
            ' ist eine Scrollbar gespeichert
            If Not tColorSB(lngItem).ScrollBar Is Nothing Then
            
                ' sind die Fensterhandle der Scrollbars gleich
                If tColorSB(lngItem).ScrollBar.hWnd = ScrollBar.hWnd Then
                
                    ' ist ein Brush für diese Scrollbar vorhanden
                    If tColorSB(lngItem).hBrush <> 0 Then
                    
                        ' alten Brush von dieser Scrollbar löschen
                        Call DeleteObject(tColorSB(lngItem).hBrush)
                        
                        ' Systemfarben konvertieren
                        If OleTranslateColor(BackColor, 0&, BackColor) = S_OK Then
                        
                            ' neuen Brush für diese Scrollbar erstellen
                            tColorSB(lngItem).hBrush = CreateSolidBrush(BackColor)
                            
                            ' erneutes zeichnen für diese Scrollbar anfordern
                            tColorSB(lngItem).ScrollBar.Refresh
                            
                        End If
                    End If
                    
                    ' Schleife verlassen
                    Exit For
                    
                End If
            End If
            
        Next lngItem
        
    End If
    
End Sub

Public Sub Hook(ByRef Frm As Form)

    ' Fensterhandle speichern
    hFrmHwnd = Frm.hWnd
    
    ' Subclassing der Form starten
    lngOldWndProc = SetWindowLong(hFrmHwnd, GWL_WNDPROC, AddressOf WindowProc)
    
End Sub

Public Sub Unhook()

    Dim lngItem As Long
    
    ' Subclassing der Form beenden
    Call SetWindowLong(hFrmHwnd, GWL_WNDPROC, lngOldWndProc)
    
    ' alle Element im Array tColorSB durchlaufen
    For lngItem = 0 To lngCount - 1
    
        ' gespeicherte Scrollbar löschen
        Set tColorSB(lngItem).ScrollBar = Nothing
        
        ' ist ein Brush für diese Scrollbar vorhanden
        If tColorSB(lngItem).hBrush <> 0 Then
        
            ' Brush löschen
            Call DeleteObject(tColorSB(lngItem).hBrush)
            
        End If
        
    Next lngItem
    
    ' Array tColorSB löschen
    Erase tColorSB
    
End Sub

Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As _
    Long, ByVal lParam As Long) As Long
    
    Dim lngItem As Long
    
    ' Nur wenn die Nachricht WM_CTLCOLORSCROLLBAR eintrifft die für das
    ' zeichnen der Hintergrundfarbe in Scrollbar-Steuerelementen verantwortlich ist.
    If uMsg = WM_CTLCOLORSCROLLBAR Then
    
        ' alle Element im Array tColorSB durchlaufen
        For lngItem = 0 To lngCount - 1
        
            ' ist eine Scrollbar gespeichert
            If Not tColorSB(lngItem).ScrollBar Is Nothing Then
        
                ' ist das Fensterhandle der Scrollbar = lParam
                If tColorSB(lngItem).ScrollBar.hWnd = lParam Then
            
                    ' ist für diese Scrollbar ein Brush vorhanden
                    If tColorSB(lngItem).hBrush <> 0 Then
                
                        ' Handle des Brush an die Funktion übergeben
                        ' damit wird die Hintergrundfarbe der Scrollbar gesetzt
                        WindowProc = tColorSB(lngItem).hBrush
                    
                        ' Schleife verlassen
                        Exit For
                    
                    End If
                End If
            End If
        Next lngItem
        
    Else
    
        ' alle anderen Nachrichten weiterleiten
        WindowProc = CallWindowProc(lngOldWndProc, hWnd, uMsg, wParam, lParam)
        
    End If
    
End Function
'------- Ende Modul "modColorSB" alias modColorSB.bas -------
'----------- Ende Projektdatei ColorScrollBar.vbp -----------