[VBnet Subclassing] WM_CTLCOLORSTATIC: Change the Backcolour of a Slider


	Visual Basic Subclassing Routines WM_CTLCOLORSTATIC: Change the BackColor of a Slider

Posted:	Wednesday April 07, 2004
Updated:	Monday December 26, 2011

Applies to:	VB5, VB6
Developed with:	VB6, Windows XP
OS restrictions:	None
Author:	Tom Esh - msnews, VBnet - Randy Birch

Related:	Pure VB: Mimicking a Command Button ForeColor Property

Prerequisites

VB5 or VB6.

By definition, windows sends a WM_CTLCOLORSTATIC message to an application parent window whenever a Static or disabled Edit the control is about to be drawn. Interestingly this also applies to VB's intrinsic Slider common control.

Through subclassing we can trap this message and by returning a brush to a desired colour as the return value of the WindowProc, the slider's BackColor will be painted with the specified brush.

Because the text label in a frame control, as well as the text portion of both a check box and option button all are created as Static windows it is necessary to restrict which Static window the WindowProc applies the coloured brush to. This is accomplished easily by storing the hwnd to the Slider in a variable, and comparing that to the value of lParam passed to the WindowProc when the WM_CTLCOLORSTATIC message is received.

The four illustrations show the states achievable with this demo. Illustration 1 shows the normal behaviour of the Slider, including ToolTips and the default vbButtonFace BackColor. Illustration 2 shows the effect of disabling the ToolTips . Illustrations 3 and 4 show the same, but this time with the subclassing enabled and a brush of dark blue.

Note: Because the brush only affects the background colour, ticks enabled through the TickStyle property retain their normal black colour regardless of the BackColor selected. Therefore testing of various BackColor/tick colour combinations is required to ensure the control's display remains legible.

BAS Module Code

Place the following code into the general declarations area of a bas module:

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public defWindowProc As Long
Public hSliderHwnd As Long
Private hSliderBGBrush As Long

Private Const WM_USER = &H400&
Private Const TBM_GETTOOLTIPS = (WM_USER + 30)
Private Const TTM_ACTIVATE = (WM_USER + 1)

Private Const GWL_WNDPROC As Long = (-4)
Private Const WM_GETMINMAXINFO As Long = &H24
Private Const WM_TIMECHANGE = &H1E
Private Const WM_DESTROY = &H2

Private Const WM_CTLCOLORSTATIC = &H138

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 CallWindowProc Lib "user32" _
   Alias "CallWindowProcA" _
  (ByVal lpPrevWndFunc As Long, _
   ByVal hWnd As Long, _
   ByVal uMsg As Long, _
   ByVal wParam As Long, _
   ByVal lParam 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 Function CreateSolidBrush Lib "gdi32" _
  (ByVal crColor As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _
   (ByVal hObject As Long) As Long



Public Sub CreateSliderBrush(clrref As Long, bReset As Boolean)

  'if the brush has already been assigned,
  'or a reset is desired, we have to clean up
  'by deleting the brush created
   If (hSliderBGBrush <> 0) Or (bReset = True) Then
      Call DeleteSliderBrush
   End If
   
   If hSliderBGBrush = 0 Then
      hSliderBGBrush = CreateSolidBrush(clrref)
   End If
   
End Sub


Public Sub DeleteSliderBrush()

   If (hSliderBGBrush <> 0) Then
      DeleteObject hSliderBGBrush
      hSliderBGBrush = 0
   End If
   
End Sub


Public Function Slider_ActivateToolTips(hwndSlider As Long, _
                                        bEnabled As Boolean) As Long

   
   Dim hToolTips As Long
   
  'retrieve the handle to the ToolTip
  'control assigned to the slider
   hToolTips = SendMessage(hwndSlider, _
                           TBM_GETTOOLTIPS, _
                           ByVal 0&, _
                           ByVal 0&)
   
   If hToolTips <> 0 Then
       
      'activate or deactivate the ToolTip control
       Slider_ActivateToolTips = SendMessage(hToolTips, _
                                             TTM_ACTIVATE, _
                                             ByVal Abs(bEnabled), _
                                             ByVal 0&)
   End If


End Function

Public Sub SubClass(hWnd As Long)

  'assign our own window message
  'procedure (WindowProc)
   On Error Resume Next
   defWindowProc = SetWindowLong(hWnd, _
                                 GWL_WNDPROC, _
                                 AddressOf WindowProc)
   
End Sub


Public Sub UnSubClass(hWnd As Long)

  'restore the default message handling
  'before exiting
   If defWindowProc Then
      SetWindowLong hWnd, GWL_WNDPROC, defWindowProc
      defWindowProc = 0
   End If
   
End Sub


Public Function WindowProc(ByVal hWnd As Long, _
                           ByVal uMsg As Long, _
                           ByVal wParam As Long, _
                           ByVal lParam As Long) As Long

  'window message procedure
   Select Case hWnd
   
     'perform form-specific message handling
     'to deal with the notifications
     '
     '**Be sure this is the name of your subclassed form!**
      Case Form1.hWnd
         
        'form-specific handler
         Select Case uMsg
            
            Case WM_CTLCOLORSTATIC
               
             'if the message is for the slider
             'and a brush for the background
             'has been created, return the
             'brush as a result of this message,
             'otherwise call CallWindowProc()
             'to process the message normally.
              If (lParam = hSliderHwnd) And (hSliderBGBrush <> 0) Then
                  
                  WindowProc = hSliderBGBrush
                  Exit Function
                     
               Else
                  
                  WindowProc = CallWindowProc(defWindowProc, _
                                              hWnd, _
                                              uMsg, _
                                              wParam, _
                                              lParam)
                
                  Exit Function
                  
               End If  'lParam = hSliderHwnd

               
            Case WM_DESTROY
               
              'this takes care of unscheduled form
              'termination - it will only fire if
              'the UnSubClass call in the form's
              '_unload event failed to be called when
              'the application received a WM_DESTROY
              'message
               If (hSliderBGBrush <> 0) Then
                  Call DeleteSliderBrush
                  hSliderBGBrush = 0
               End If
               
               Call UnSubClass(hWnd)
               
            Case Else
            
              'if subclassing has been activated, and
              'the hwnd is that of the form, pass
              'messages to the default message handler
               WindowProc = CallWindowProc(defWindowProc, _
                                            hWnd, _
                                            uMsg, _
                                            wParam, _
                                            lParam)
               Exit Function
            
          End Select
          
      
      Case Else
      
     'this takes care of messages when the
     'handle specified is not that of the form
      WindowProc = CallWindowProc(defWindowProc, _
                                  hWnd, _
                                  uMsg, _
                                  wParam, _
                                  lParam)
   End Select
   
End Function

Form Code

To a form, add a two command buttons (Command1, Command2), a slider from the common controls (Slider1), and a check box (Check1). Add the following code:

Option Explicit

Private Sub Form_Load()

   Command1.Caption = "Setup && Subclass"
   Command2.Caption = "Quit"
   Check1.Caption = "Enable Slider ToolTips"
   Check1.Value = vbChecked
    
End Sub


Private Sub Command1_Click()

  'create a new colour brush with which to
  'paint the slider background
   CreateSliderBrush RGB(40, 40, 130), False
   
  'Before subclassing, we assign the slider's hwnd
  'to a variable. In the WindowProc routine, when
  'a WM_CTLCOLORSTATIC message is received, we
  'test for this value and only apply the brush
  'if lParam in the call = this handle. Failing to
  'do this will cause all controls on the form
  'painted via the WM_CTLCOLORSTATIC message to
  'assume the backcolor specified by the hBrush
   hSliderHwnd = Slider1.hWnd
  
  'subclass the form (not the slider) as
  'the WM_CTLCOLORSTATIC message is sent
  'to the control's container
   Call SubClass(Me.hWnd)
   
  'prevent re-subclassing
   Command1.Enabled = False
   
End Sub


Private Sub Command2_Click()

   Unload Me
   
End Sub


Private Sub Form_Unload(Cancel As Integer)

  'only attempt to unhook the subclassing
  'routine if the form is actually subclassed
   If defWindowProc <> 0 Then
      Call UnSubClass(Me.hWnd)
   End If
   
  'and delete any brush used.
   Call DeleteSliderBrush

End Sub


Private Sub Check1_Click()

  'enable/disable annoying tooltips by passing
  'false to turn off, or true to turn on
   Slider_ActivateToolTips Slider1.hWnd, (Check1.Value = vbChecked)
   
End Sub

Comments

Save the project and use Run > Start with full compile to check for errors. If VB terminates on clicking the Setup & Subclass, chances are the name of the form is different than Form1 used in WindowProc - change that to your subclassed form name.

PayPal Link