[VBnet Subclassing] WM_PAINT: Subclassing to Create a Flat Combo Box


	Visual Basic Subclassing Routines WM_PAINT: Subclassing to Create a Flat Combo Box

Posted:	Wednesday November 24, 1999
Updated:	Monday December 26, 2011

Applies to:	VB5, VB6
Developed with:	VB6, Windows 98
OS restrictions:	None
Author:	Klaus Probst, VBnet - Randy Birch

Prerequisites

VB5 or VB6.

Office 97 made popular the Flat combo box, and while it takes some work to get a VB combo to react as the Office 97 one does, it is a straight forward exercise to simply adjust the combo box edge styles via subclassing to provide the appearance of a flat or stylized combo.

Unlike other controls, the combo redraws its frame elements whenever it receives a paint message. This anomaly removes the possibility of using straight-forward style-bit change to affect a change in the control's appearance. So, by subclassing the combo and responding to the WM_PAINT message sent it, we can introduce our own modifications to the edge styles, which includes eliminating them altogether.

This demo then shows how to subclass and capture the WM_PAINT message for the combo, and in doing so display the combo in three different styles - normal, borderless (aka flat), and with a softer combo edge (my favourite). The illustration at the top shows the effect in Windows 2000 and earlier, while the bottom is for Windows XP using a manifest for to achieve the XP styles on a VB form. On both illustrations, the top combo shows how the the normal VB appears by default, while the middle combo is this same "normal VB combo" but with the subclassing applied in flat mode. The final combo on each form has subclassing, but with the soft edge style applied. Note those with the the drop shadow are taken from second screen captures of Combo2, so for this demo you only need to add two combos to the form and the code will toggle the look of the second combo.

The code for the flat combo is by Klaus Probst as provided in the msnews WinAPI newsgroup. The subclassing routine uses Karl Peterson's HookMe routine, and is used with permission.

BAS Module - 'HookMe.bas'

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.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' *************************************************************************
'  Copyright (C)1997 Karl E. Peterson and Zane Thomas, All Rights Reserved
'
'  Used at VBnet by permission.
'  For the latest version see the Tools section at http://www.mvps.org/vb/
' *************************************************************************
'  Warning: This computer program is protected by copyright law and
'  international treaties. Unauthorized reproduction or distribution
'  of this program, or any portion of it, may result in severe civil
'  and criminal penalties, and will be prosecuted to the maximum
'  extent possible under the law.
' *************************************************************************

Public Declare Function GetProp Lib "user32" _
   Alias "GetPropA" _
  (ByVal hwnd As Long, ByVal lpString As String) As Long

Public 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 SetProp Lib "user32" _
   Alias "SetPropA" _
  (ByVal hwnd As Long, ByVal lpString As String, _
   ByVal hData As Long) As Long

Private Declare Function SetWindowLong Lib "user32" _
   Alias "SetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long, _
   ByVal wNewWord As Long) As Long

Private Declare Function GetWindowLong Lib "user32" _
   Alias "GetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (Destination As Any, Source As Any, ByVal Length As Long)

Private Const GWL_WNDPROC  As Long = (-4)


Public Function HookFunc(ByVal hwnd As Long, _
                         ByVal msg As Long, _
                         ByVal wp As Long, _
                         ByVal lp As Long) As Long
   Dim foo As Long
   Dim obj As Form1

   foo = GetProp(hwnd, "ObjectPointer")
   '
   ' Ignore "impossible" bogus case
   '
   If (foo <> 0) Then
      CopyMemory obj, foo, 4
      On Error Resume Next
      HookFunc = obj.WindowProc(hwnd, msg, wp, lp)
      If (Err) Then
         UnhookWindow hwnd
         Debug.Print "Unhook on Error, #"; CStr(Err.Number)
         Debug.Print "  Desc: "; Err.Description
         Debug.Print "  Message, hWnd: &h"; Hex(hwnd), "Msg: &h"; Hex(msg), "Params:"; wp; lp
      End If
      '
      ' Make sure we don't get any foo->Release() calls
      '
      foo = 0
      CopyMemory obj, foo, 4
   End If
End Function


Public Sub HookWindow(hwnd As Long, thing As Object)

   Dim foo As Long

   CopyMemory foo, thing, 4

   Call SetProp(hwnd, "ObjectPointer", foo)
   Call SetProp(hwnd, "OldWindowProc", GetWindowLong(hwnd, GWL_WNDPROC))
   Call SetWindowLong(hwnd, GWL_WNDPROC, AddressOf HookFunc)

End Sub


Public Sub UnhookWindow(hwnd As Long)
   Dim foo As Long

   foo = GetProp(hwnd, "OldWindowProc")
   If (foo <> 0) Then
      Call SetWindowLong(hwnd, GWL_WNDPROC, foo)
   End If
End Sub


Public Function InvokeWindowProc(hwnd As Long, _
                                 msg As Long, _
                                 wp As Long, _
                                 lp As Long) As Long
                                 
   InvokeWindowProc = CallWindowProc(GetProp(hwnd, "OldWindowProc"), _
                                     hwnd, msg, wp, lp)
   
End Function

Form Code

Add a form to the project and leave the name as Form1. If you chose another name, remember to change the HookFunc declare from "Dim Form1 as Object" to the correct name of your form!!

Add two combos to the form (Combo1 and Combo2), as well as two command buttons (Command1 and Command2). The third combo in the illustration is a replication of the subclassed combo showing the second style appearance. Labels are optional. Add the following code to the form:

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.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Klaus H. Probst - http://www.vbbox.com/

Private cStyle As Boolean

'DrawEdge() constants
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENINNER = &H8
Private Const BDR_OUTER = &H3
Private Const BDR_INNER = &HC
Private Const BDR_RAISED = &H5
Private Const BDR_SUNKEN = &HA

Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_INNER = (BDR_SUNKENINNER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)

Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8

Private Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const BF_DIAGONAL = &H10

Private Const BF_DIAGONAL_ENDTOPRIGHT = (BF_DIAGONAL Or BF_TOP Or BF_RIGHT)
Private Const BF_DIAGONAL_ENDTOPLEFT = (BF_DIAGONAL Or BF_TOP Or BF_LEFT)
Private Const BF_DIAGONAL_ENDBOTTOMLEFT = (BF_DIAGONAL Or BF_BOTTOM Or BF_LEFT)
Private Const BF_DIAGONAL_ENDBOTTOMRIGHT = (BF_DIAGONAL Or BF_BOTTOM Or BF_RIGHT)

Private Const BF_MIDDLE = &H800    'Fill in the middle.
Private Const BF_SOFT = &H1000     'Use for softer buttons.
Private Const BF_ADJUST = &H2000   'Calculate the space left over.
Private Const BF_FLAT = &H4000     'For flat rather than 3-D borders.
Private Const BF_MONO = &H8000&    'For monochrome borders

Private Const WM_PAINT = &HF

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Declare Function DrawEdge Lib "user32" _
  (ByVal hDC As Long, _
   qrc As RECT, _
   ByVal edge As Long, _
   ByVal grfFlags As Long) As Long

Private Declare Function GetWindowDC Lib "user32" _
   (ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" _
  (ByVal hwnd As Long, _
   ByVal hDC As Long) As Long

Private Declare Function GetClientRect Lib "user32" _
  (ByVal hwnd 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 Sub Command1_Click()

  'this alters the subclassed state (for comparing)
   Static cBorder As Boolean
   
   cBorder = Not cBorder
   Command1.Caption = IIf(cBorder, "Subclassed", "Normal")
   Command2.Enabled = cBorder = True
   
   If cBorder Then
      Call HookWindow(Combo2.hwnd, Me)
   Else
      Call UnhookWindow(Combo2.hwnd)
   End If
   
   Combo2.Refresh
   
End Sub


Private Sub Command2_Click()

  'this just demos two possible style
  'combinations used in the WindowProc
  'WM_PAINT message
   cStyle = Not cStyle
   
   Command2.Caption = IIf(cStyle, "Soft", "Flat")
   
   Combo2.Refresh
   
End Sub


Private Sub Form_Load()

   Dim cnt As Long
   
  'add a few fonts to both combos
   For cnt = 1 To Screen.FontCount \ 2
       Combo2.AddItem Screen.Fonts(cnt)
       Combo1.AddItem Screen.Fonts(cnt)
   Next cnt
   
  'set options and subclass
   Command2_Click
   Command1_Click

End Sub


Private Sub Form_Unload(Cancel As Integer)

   Call UnhookWindow(Combo2.hwnd)

End Sub


Friend Function WindowProc(hwnd As Long, _
                           msg As Long, _
                           wp As Long, _
                           lp As Long) As Long
   
   Dim hDcCombo As Long
   Dim rc As RECT

   Select Case hwnd
      Case Combo2.hwnd
         
         Select Case msg
         
            Case WM_PAINT
            
               WindowProc = CallWindowProc(GetProp(hwnd, _
                                           "OldWindowProc"), _
                                           hwnd, msg, _
                                           wp, lp)
               
               hDcCombo = GetWindowDC(hwnd)
               Call GetClientRect(hwnd, rc)
                 
               If cStyle Then
                 
                  Call DrawEdge(hDcCombo, rc, _
                                BDR_RAISEDINNER, _
                                BF_RECT Or _
                                BF_FLAT Or _
                                BF_ADJUST)
                                
                  Call InflateRect(rc, -1, -1)
                  
                  Call DrawEdge(hDcCombo, rc, _
                                BDR_RAISEDINNER, _
                                BF_RECT Or _
                                BF_FLAT Or _
                                BF_ADJUST)
                                
                  Call ReleaseDC(hwnd, hDcCombo)
               
               Else
               
                  Call DrawEdge(hDcCombo, rc, _
                                BDR_RAISEDINNER, _
                                BF_RECT Or _
                                BF_FLAT)
                                
                  Call InflateRect(rc, -1, -1)
                  
                  Call DrawEdge(hDcCombo, rc, _
                                BDR_RAISEDINNER, _
                                BF_RECT Or _
                                BF_FLAT)
                  
                  Call ReleaseDC(hwnd, hDcCombo)
                 
               End If
         
             Case Else
             
                'Pass to default window procedure
                 WindowProc = CallWindowProc(GetProp(hwnd, _
                                             "OldWindowProc"), _
                                             hwnd, msg, _
                                             wp, lp)
                 
         End Select

      Case Else
        
        'Pass to default window procedure
         WindowProc = CallWindowProc(GetProp(hwnd, _
                                     "OldWindowProc"), _
                                     hwnd, msg, _
                                     wp, lp)
   End Select

End Function

Comments

Save then run the project. Combo2 will appear with the soft style. Pressing the 'Soft' button will toggle the style to Flat and back. Command1 turns the subclassing off.

PayPal Link