VB 5/6-Tipp 0766: Hintergrundfarbe von Scrollbar-Steuerelementen ändern
von Frank Schüler
Beschreibung
Für die Scrollbar-Steuerelemente wurde leider die BackColor-Eigenschaft vergessen. Dieses Beispiel zeigt wie die Hintergrundfarbe von Scrollbar-Steuerelementen geändert werden kann.
Schwierigkeitsgrad: | Verwendete API-Aufrufe: CallWindowProcA (CallWindowProc), CreateSolidBrush, DeleteObject, OleTranslateColor, SetWindowLongA (SetWindowLong) | Download: |
'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 -----------
Tipp-Kompatibilität:
Windows/VB-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
VB4 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
VB5 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
VB6 | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() | ![]() |
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.