[VBnet ComCtrls] CreateWindowEx: Create the Common Control Header


	Visual Basic Common Control API Routines CreateWindowEx: Create the Common Control Header

Posted:	Sunday January 25, 1998
Updated:	Monday December 26, 2011

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

Prerequisites

Enhanced Comctl32 functionality is only available to users with comctl32.dll version 4.70 or greater installed. This dll is typically installed with IE3.x or greater.

This project also requires the BAS module constructed in the accompanying article InitCommonControlsEx: Common Control Initialization Module.

If you're like myself, you've probably wished that some of Visual Basic's other controls provided the look (and functionality) of a ListView's header. In this example, we'll use the API to create a real header control and position it overtop a list or textbox.

The method below does not provide any functionality to that control; it does not perform a sort of the contents in response to mouse clicks. It does however indicate the steps needed to create and position the control, and the missing sorting functionality could then be supplied by you by subclassing the control and responding to the passed HHT_XXX messages.

BAS Module Code

Add the following code to 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.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'====== HEADER CONTROL ========
Public Const HEADER32_CLASS = "SysHeader32"
Public Const HEADER_CLASS = "SysHeader"

Public Type HD_ITEM
   mask        As Long
   cxy         As Long
   pszText     As String
   hbm         As Long
   cchTextMax  As Long
   fmt         As Long
   lParam      As Long
  'index of bitmap in ImageList: comctl 4.70+
   iImage      As Long
  'where to draw this item: comctl 4.70+
   iOrder      As Long
End Type

'Header info
Public Const HDI_WIDTH = &H1
Public Const HDI_HEIGHT = HDI_WIDTH
Public Const HDI_TEXT = &H2
Public Const HDI_FORMAT = &H4
Public Const HDI_LPARAM = &H8
Public Const HDI_BITMAP = &H10
Public Const HDI_IMAGE = &H20
Public Const HDI_DI_SETITEM = &H40
Public Const HDI_ORDER = &H80

'Header formats
Public Const HDF_LEFT = 0
Public Const HDF_RIGHT = 1
Public Const HDF_CENTER = 2
Public Const HDF_JUSTIFYMASK = &H3
Public Const HDF_RTLREADING = 4
Public Const HDF_IMAGE = &H800
Public Const HDF_OWNERDRAW = &H8000&
Public Const HDF_STRING = &H4000
Public Const HDF_BITMAP = &H2000
Public Const HDF_BITMAP_ON_RIGHT = &H1000

'Header styles
Public Const HDS_HORZ = &H0
Public Const HDS_BUTTONS = &H2
Public Const HDS_HOTTRACK = &H4
Public Const HDS_HIDDEN = &H8
Public Const HDS_DRAGDROP = &H40
Public Const HDS_FULLDRAG = &H80

'Header messages
Public Const HDM_FIRST = &H1200
Public Const HDM_GETITEMCOUNT = (HDM_FIRST + 0)
Public Const HDM_INSERTITEM = (HDM_FIRST + 1)
Public Const HDM_DELETEITEM = (HDM_FIRST + 2)
Public Const HDM_GETITEM = (HDM_FIRST + 3)
Public Const HDM_SETITEM = (HDM_FIRST + 4)
Public Const HDM_LAYOUT = (HDM_FIRST + 5)
Public Const HDM_HITTEST = (HDM_FIRST + 6)
Public Const HDM_GETITEMRECT = (HDM_FIRST + 7)
Public Const HDM_SETIMAGELIST = (HDM_FIRST + 8)
Public Const HDM_GETIMAGELIST = (HDM_FIRST + 9)
Public Const HDM_ORDERTOINDEX = (HDM_FIRST + 15)

'Header hittest messages
Public Const HHT_NOWHERE = &H1
Public Const HHT_ONHEADER = &H2
Public Const HHT_ONDIVIDER = &H4
Public Const HHT_ONDIVOPEN = &H8
Public Const HHT_ABOVE = &H100
Public Const HHT_BELOW = &H200
Public Const HHT_TORIGHT = &H400
Public Const HHT_TOLEFT = &H800

Public Type WINDOWPOS
   hwnd  As Long
   hWndInsertAfter As Long
   X     As Long
   Y     As Long
   cx    As Long
   cy    As Long
   flags As Long
End Type

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

Public Type HD_LAYOUT
    rc As RECT
    wp As WINDOWPOS
End Type

Public Type POINTAPI
   X As Long
   Y As Long
End Type

Public Type HD_HITTESTINFO
   pt    As POINTAPI
   flags As Long
   iItem As Long
End Type

'====== OTHER NEEDED APIs ========

Public Const DEFAULT_GUI_FONT = 17
Public Const WM_SETFONT = &H30

Public Const WS_VISIBLE = &H10000000
Public Const WS_CHILD = &H40000000
Public Const WS_BORDER = &H800000
Public Const SWP_SHOWWINDOW = &H40

Public Declare Function GetStockObject Lib "gdi32" _
   (ByVal nIndex As Long) As Long

Public Declare Function GetDC Lib "user32" _
   (ByVal hwnd As Long) As Long
   
Public Declare Function SelectObject Lib "gdi32" _
   (ByVal hdc As Long, _
    ByVal hObject As Long) As Long
    
Public Declare Function DeleteObject Lib "gdi32" _
   (ByVal hObject As Long) As Long

Public 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

Public Declare Function ShowWindow Lib "user32" _
   (ByVal hwnd As Long, _
    ByVal nCmdShow As Long) As Long

Public Declare Function DestroyWindow Lib "user32" _
   (ByVal hwnd As Long) As Long

Public Declare Function SendMessage Lib "user32" _
   Alias "SendMessageA" _
   (ByVal hwnd As Long, ByVal wMsg As Long, _
    ByVal wParam As Any, lParam As Any) As Long
    
Public Declare Function IsWindow Lib "user32" _
   (ByVal hwnd As Long) As Long
   
Public Declare Function MoveWindow Lib "user32" _
   (ByVal hwnd As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long
   
Public Declare Function SetWindowPos Lib "user32" _
   (ByVal hwnd As Long, _
    ByVal hWndInsertAfter As Long, _
    ByVal X As Long, ByVal Y As Long, _
    ByVal cx As Long, ByVal cy As Long, _
    ByVal wFlags As Long) As Long

Public Declare Function GetClientRect Lib "user32" _
   (ByVal hwnd As Long, lpRect As RECT) As Long

Form Code

The form shown appears straightforward, but there are several frames utilized with their border style set to 0 in order to accommodate the option buttons. The following controls are required to create the demo as shown:

4 command buttons : cmdDestroy, cmdModify, cmdCreate, cmdEnd
1 listbox: List1
4 textboxes: Text1, txtNumHeaders, txtHeaderHeight, txtHeaderCaption
4 option button arrays: optPosOver(0/1), optPosition(0/1/2), optAppearance(0/1) ,optBitmapPos(0/1)
1 checkbox array: chkHDStyles(0/1)
2 checkboxes: chkIncludeBitmaps, chkImageOnly
6 labels in an array: Label1(0/1/2/3/4/5)
1 imagelist containing several different 16x16 images.

If you need help, I've saved a monochrome control layout map form with the control names substituted for the captions (link opens a new browser window).

Option Explicit

Dim hHeader As Long

'constants for the option indices
Private Const putBitmapLeft As Integer = 0
Private Const putBitmapRight As Integer = 1
Private Const putOverList As Integer = 0
Private Const putOverText As Integer = 1

Private Const putCaptionLeft As Integer = 0
Private Const putCaptionCentre As Integer = 1
Private Const putCaptionRight As Integer = 2

Private Const styleFlat = 0
Private Const styleHasButtons = 1
Private Const styleHottrack = 0
Private Const styleMoveable = 1
   

Private Sub chkIncludeBitmaps_Click()

   optBitmapPos(putBitmapLeft).Enabled = _
          chkIncludeBitmaps.Value = 1
   optBitmapPos(putBitmapRight).Enabled = _
          chkIncludeBitmaps.Value = 1

End Sub


Private Sub cmdEnd_Click()

  'Free all resources associated with the header
  
   If IsWindow(hHeader) Then
      Call DestroyWindow(hHeader)
   End If
   
   Unload Me
  
End Sub


Private Sub cmdCreateSimpleHeader_Click()

   Dim ctrlWidth As Long
   Dim headerTotalButtons As Integer
   Dim headerHeight As Integer
   Dim nWidth As Long
   Dim i As Long
   
   Dim targetControl As Control
   
  'retrieve the values from the text boxes
   headerTotalButtons = Val(txtNumHeaders)
   headerHeight = Val(txtHeaderHeight)
     
  'create a header using the styles set from
  'the form.  Note that this creates the
  'header but it is not yet visible.
  'Return the handle to the new header (hHeader)
   hHeader = CreateHeader()
   
  'if a handle exists ...
   If hHeader > 0 Then
   
     'determine the control to position the header over
     'Assume that the target is the listbox unless
     'optPosOver(1) is on.
      Set targetControl = List1
      If optPosOver(putOverText) Then Set targetControl = Text1

     'move the header over the specified control
     '(targetcontrol), and returns the final width
     'of the header.
     
     'This displays the header in the correct position
     '(visible), but as the header as yet to have any
     'header items set, the result is a gray panel
     'invisible on a gray form.
      ctrlWidth = PositionHeader(hHeader, targetControl, headerHeight)
      
     'calc the width of each control by dividing the
     'size of the control by the number of header
     'columns requested.
      nWidth = (targetControl.Width / Screen.TwipsPerPixelX) _
                        / headerTotalButtons
    
     'For each, add a header item.
     'This example uses the index to set both the
     'header index AND the imagelist picture to
     'assign, so assure that sufficient imagelist
     'icons exist in your imagelist!!
     'Setting the last param False causes the
     'AddHeaderItem routine to ignore the imagelist
     'item passed.
      For i = 0 To headerTotalButtons - 1
      
         AddHeaderItem hHeader, _
                       i, _
                       nWidth, _
                       Trim$(txtHeaderCaption) & " " & CStr(i), _
                       i + 1, _
                       True
      Next
      
   End If
   
  'disable most controls we can't set while running
   SetControlStates (hHeader = 0)

End Sub


Private Sub cmdDestroy_Click()
  
   If IsWindow(hHeader) Then
      Call DestroyWindow(hHeader)
      hHeader = False
   End If

   SetControlStates (hHeader = False)
   
End Sub


Private Sub cmdModify_Click()

   Dim nWidth As Long
   Dim i As Long
   Dim headerTotalButtons As Long
   
   headerTotalButtons = SendMessage(hHeader, _
                                    HDM_GETITEMCOUNT, _
                                    0&, ByVal 0&)

  'For each, add a header item.
  'This example uses the index to set both the
  'header index AND the imagelist picture to
  'assign, so assure that sufficient imagelist
  'icons exist in your imagelist!!
  'Setting the last param False causes the
  'AddHeaderItem routine to ignore the imagelist
  'item passed.
   nWidth = (List1.Width / Screen.TwipsPerPixelX) _
                         / headerTotalButtons
   
   For i = 0 To headerTotalButtons - 1
   
      Call SendMessage(hHeader, HDM_DELETEITEM, i, ByVal 0&)
      AddHeaderItem hHeader, _
                    i, _
                    nWidth, _
                    Trim$(txtHeaderCaption) & " " & CStr(i), _
                    i + 1, _
                    True
   Next

End Sub


Private Sub Form_Load()

   Dim r As Boolean
   Dim tmp As String
   
  'perform some setup
   List1.AddItem "VBnet Home"
   List1.AddItem "Microsoft Home"
   List1.AddItem "MSDN Home"
   List1.AddItem "Visual Basic Home"
   List1.AddItem "Visual Studio Home"
   
   tmp = "VBnet Home" & vbCrLf
   tmp = tmp & "Microsoft Home" & vbCrLf
   tmp = tmp & "MSDN Home" & vbCrLf
   tmp = tmp & "Visual Basic Home" & vbCrLf
   tmp = tmp & "Visual Studio Home"
   
   Text1.Text = tmp
   
  'initialize the common controls
  'Note that the header class is initialized
  'by passing the ICC_LISTVIEW_CLASSES flag 
   If IsNewComctl32(ICC_LISTVIEW_CLASSES) = False Then
      tmp = "You do not have the latest comctrl32.dll"
      tmp = tmp & "  file installed. All features of "
      tmp = tmp & "the common controls may not be available."
      MsgBox tmp
   End If
   
  'finally, setup the controls
   optPosOver(0).Value = True
   chkIncludeBitmaps_Click
    
   SetControlStates hHeader = 0

End Sub


Private Function CreateHeader()

  Dim dwHeaderStyles As Long
  
  'create a variable with the selected header styles
   dwHeaderStyles = CreateHeaderStyles()
  
  'Create the header using window style returned
   hHeader = CreateWindowEx(0, HEADER32_CLASS, vbNullString, _
                            dwHeaderStyles, _
                            0, 0, 0, 0, _
                            hwnd, 0, _
                            App.hInstance, ByVal 0)
                              
  'even though it's a form-wide variable, return
  'the handle as an indicator of success
   CreateHeader = hHeader
   
End Function


Private Function PositionHeader(hHeader As Long, _
                                ctrl As Control, _
                                headerHeight As Integer) As Long

  'pass a control to this routine, and the header
  'will position itself over it at the height specified.
   Dim rc As RECT
   Dim hFont As Long
   Dim hOldFont As Long
  
   rc.Left = ctrl.Left / Screen.TwipsPerPixelX
  'offset the header by 2 (headerHeight - 2) to
  'align the header exactly with the top of the
  'control container.
   rc.Top = (ctrl.Top - ((headerHeight - 2) * Screen.TwipsPerPixelX)) _
             / Screen.TwipsPerPixelY
   rc.Right = (ctrl.Width) / Screen.TwipsPerPixelX
   rc.Bottom = headerHeight
   
  'move the header into position
   Call SetWindowPos(hHeader, 0&, _
                     rc.Left, rc.Top, _
                     rc.Right, rc.Bottom, _
                     SWP_SHOWWINDOW)
   
  'if these next three lines aren't used, the
  'header appears to use fixedsys bold fonts!!
   hFont = GetStockObject(DEFAULT_GUI_FONT)
   hOldFont = SelectObject(hHeader, hFont)
   Call SendMessage(hHeader, WM_SETFONT, hFont, ByVal True)
   
  'and return the size of the control
   PositionHeader = (ctrl.Width) / Screen.TwipsPerPixelX

End Function


Private Function CreateHeaderStyles() As Long

   Dim style As Long
   
  'these are the minimum requirements...
   style = WS_CHILD Or HDS_HORZ
   
   If optAppearance(styleHasButtons) Then style = style Or HDS_BUTTONS
   If chkHDStyles(styleHottrack) Then style = style Or HDS_HOTTRACK
   If chkHDStyles(styleMoveable) Then style = style Or HDS_DRAGDROP
      
   CreateHeaderStyles = style

End Function


Private Sub AddHeaderItem(hHeader As Long, itemNo As Long, _
                          nItemWidth As Long, _
                          sCaption As String, _
                          nImageNo As Long, _
                          useImage As Boolean)

   Dim HDI As HD_ITEM
   
   With HDI
      .mask = CreateHeaderItemMask()
      .fmt = CreateHeaderItemFormats()
      .cxy = nItemWidth
      .pszText = sCaption
      .cchTextMax = Len(HDI.pszText)
   
      If useImage Then
         .hbm = ImageList1.ListImages(nImageNo).Picture
      End If
      
   End With
   
   Call SendMessage(hHeader, HDM_INSERTITEM, itemNo, HDI)
   
End Sub


Private Function CreateHeaderItemFormats() As Long

   Dim fmt As Long
   
   fmt = HDF_STRING Or HDF_LEFT
   
  'image, text or both?
   If chkImageOnly.Value = False Then
      fmt = fmt Or HDF_STRING
   End If
  
  'caption alignment
   If optPosition(putCaptionLeft).Value Then fmt = fmt Or HDF_LEFT
   If optPosition(putCaptionCentre).Value Then fmt = fmt Or HDF_RIGHT
   If optPosition(putCaptionRight).Value Then fmt = fmt Or HDF_CENTER
  
  'bitmaps
   If chkIncludeBitmaps.Value = 1 Then
      If optBitmapPos(putBitmapLeft) Then
         fmt = fmt Or HDF_BITMAP
      Else
         fmt = fmt Or HDF_BITMAP_ON_RIGHT
      End If
   End If
   
   CreateHeaderItemFormats = fmt
     
End Function


Private Function CreateHeaderItemMask() As Long

   Dim headerMask As Long
   
  'basic mask
   headerMask = HDI_FORMAT Or HDI_HEIGHT Or HDI_WIDTH
   
  'image, text or both?
   If chkImageOnly.Value = False Then
      headerMask = headerMask Or HDI_TEXT
   End If
  
  'bitmaps
   If chkIncludeBitmaps.Value = 1 Then
      headerMask = headerMask Or HDI_BITMAP
   End If
   
   CreateHeaderItemMask = headerMask
   
End Function


Private Sub SetControlStates(state As Boolean)

   cmdCreateSimpleHeader.Enabled = state
   cmdDestroy.Enabled = Not state
   cmdModify.Enabled = Not state
   
   optPosOver(putOverList).Enabled = state
   optPosOver(putOverText).Enabled = state
   optAppearance(styleFlat).Enabled = state
   optAppearance(styleHasButtons).Enabled = state
   chkHDStyles(styleHottrack).Enabled = state
   chkHDStyles(styleMoveable).Enabled = state

End Sub

Comments

Save and run the project. Set the No of Columns to add to the new header, their height (18-21 is a good start), and some text to display as the header caption. In addition, specify whether to display the header over the list or textbox .. you can add any other control type as well, and simply set the targetControl to point to this control.

In the Appearance area, set the default styles for the header. You can accept the default formats in the Header Format Options frames, and can change these while the header exists.

Clicking the Create button creates the header with the attributes selected. Once created, you can see other combinations of attributes by setting and clicking the Modify button. Modify is a bit of a misnomer .. in actuality I'm using the HDM_DELETEITEM and HDM_INSERTITEM messages to destroy and recreate a header. You could also use the HDM_SETITEM message, but you will first need to retrieve the current state using HDM_GETITEM, flip the appropriate flags, and then call SendMessage with _SETITEM to set the new attributes.

You can delete the header using the Destroy button, reset the style flags, and see the new behaviour.

The code detailed here applies the same attributes to all header items, that is, all left, all right, all with images etc. You can of course selectively set each header item's format individually at either the HDM_INSERTITEM time or using HDM_SETITEM as mentioned above.

To exit, be sure to use the cmdEnd button and not the IDE stop button to conserve Windows resources.

PayPal Link