Visual Basic Subclassing Routines
WM_NOTIFY: Detect Sizing Notifications from a ListView ColumnHeader
     
Posted:   Saturday July 31, 1999
Updated:   Monday December 26, 2011
     
Applies to:   VB5, VB6
Developed with:   VB6, Windows NT4
OS restrictions:   None
Author:   VBnet - Randy Birch
     
 Prerequisites
VB5 or VB6. This code was developed using the VB6 mscomctl.ocx ListView. It should function against the VB5 ListView control as well.

Here is a means to track the activity when a user is interacting with a ListView control's ColumnHeaders.

In the WindowProc method you will find ways to get the current cursor position on the header, information about the item selected, and how to respond to notifications sent to the parent ListView when the ColumnHeaders are used. In addition, I added a line of code in the HDN_BEGINTRACK area to show how to restrict (prevent) a user from resizing a particular column.

Remember that while the ListView ColumnHeader collection is 1-based, the API return values are 0-based.  The page also demonstrates drag/drop to reorder the column headers of a ListView in report view.

This routine uses Karl Peterson's HookMe subclassing method.

 BAS Module 1 Code: 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.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'*************************************************************************
' HookMe.bas
' 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.
'
'Used at VBnet with permission.
'*************************************************************************
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 frmMain

   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
 BAS Module 2 Code: ListView Header API
Place the following code into the general declarations area of a second 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 Const ICC_LISTVIEW_CLASSES  As Long = &H1
Public Const LVM_FIRST = &H1000
Public Const LVM_GETHEADER = (LVM_FIRST + 31)

Public Type NMHDR
   hWndFrom As Long
   idfrom   As Long
   code     As Long
End Type

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
   iImage      As Long
   iOrder      As Long
End Type

Public Type NMHEADER
   hdr         As NMHDR
   iItem       As Long
   iButton     As Long
   hbm         As Long
   HDI         As HD_ITEM
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

Public Type tagINITCOMMONCONTROLSEX 
   dwSize As Long 
   dwICC As Long
End Type

'HitTest positions
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

'header class id's
Public Const HEADER32_CLASS   As String = "SysHeader32"
Public Const HEADER_CLASS     As String = "SysHeader"

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

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

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

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

'notify messages
Public Const HDN_FIRST As Long = -300&  
Public Const HDN_ITEMCLICK = (HDN_FIRST - 2)
Public Const HDN_DIVIDERDBLCLICK = (HDN_FIRST - 5)
Public Const HDN_BEGINTRACK = (HDN_FIRST - 6)
Public Const HDN_ENDTRACK = (HDN_FIRST - 7)
Public Const HDN_TRACK = (HDN_FIRST - 8)
Public Const HDN_GETDISPINFO = (HDN_FIRST - 9)
Public Const HDN_BEGINDRAG = (HDN_FIRST - 10)
Public Const HDN_ENDDRAG = (HDN_FIRST - 11)
Public Const HDN_ITEMCHANGING As Long = (HDN_FIRST - 0)
Public Const HDN_ITEMDBLCLICK As Long = (HDN_FIRST - 3)

Public Const NM_FIRST As Long = &H0
Public Const NM_RCLICK As Long = (NM_FIRST - 5)

'windows constants
Public Const GWL_STYLE        As Long = (-16)
Public Const WM_USER  As Long = &H400
Public Const WM_SIZE  As Long = &H5
Public Const WM_NOTIFY        As Long = &H4E&

Public Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (Destination As Any, Source As Any, _
   ByVal Length As Long)
   
Public Declare Function GetCursorPos Lib "user32" _
   (lpPoint As POINTAPI) As Long
   
Public Declare Function GetWindowLong Lib "user32" _
   Alias "GetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long) As Long
   
Public Declare Sub InitCommonControls Lib "comctl32" ()

Public Declare Function InitCommonControlsEx Lib "comctl32" _
   (lpInitCtrls As tagINITCOMMONCONTROLSEX) As Boolean
   
Public Declare Function ScreenToClient Lib "user32" _
   (ByVal hwnd As Long, lpPoint As POINTAPI) 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 SetWindowLong Lib "user32" _
   Alias "SetWindowLongA" _
  (ByVal hwnd As Long, _
   ByVal nIndex As Long, _
   ByVal dwNewLong As Long) As Long


Public Function IsNewComctl32(dwFlags As Long) As Boolean

'Returns True if the current working version of Comctl32.dll
'supports the new IE3 styles & msgs. Returns False if old version.
'Also ensures that the Comctl32.dll library is loaded for use.
'This hack is much easier than checking the file version...
'VB resolves API function names only when they're called,
'not when it compiles code!
   Dim icc As tagINITCOMMONCONTROLSEX
   
   On Error GoTo Err_InitOldVersion
   
   icc.dwSize = Len(icc)
   icc.dwICC = dwFlags
   
  'VB will generate error 453 "Specified DLL function not found"
  'here if the new version isn't installed.
   IsNewComctl32 = InitCommonControlsEx(icc)
   
   Exit Function
   
Err_InitOldVersion:
   InitCommonControls
   
End Function
 Form Code
Add two Command buttons to the form (Command1/Command2), as well as a listbox (List1), a listview control (ListView1) and a label (Label1). Add three or more ColumnHeaders to the listvew and set the listview to report mode. Important: name the form frmMain (to match the HookMe code above) and add the following code:

Option Explicit

Friend Function WindowProc(hwnd As Long, _
                           msg As Long, _
                           wp As Long, _
                           lp As Long) As Long
   
   Static nm As NMHDR
   Static pt As POINTAPI
   Static HTI As HD_HITTESTINFO
    
   Dim hHeader As Long
   Dim thisIndex As Long
   
   If hwnd = ListView1.hwnd Then
  
      Select Case msg
         Case WM_NOTIFY
         
           'Pass along to default window procedure.
            WindowProc = CallWindowProc(GetProp(hwnd, _
                                               "OldWindowProc"), _
                                               hwnd, msg, _
                                               wp, lp)
            
           'Get the notification message
            Call CopyMemory(nm, ByVal lp, Len(nm))
            
           'get the hwnd of the header
            hHeader = SendMessage(ListView1.hwnd, _
                                         LVM_GETHEADER, _
                                         0&, _
                                         ByVal 0&)
            
            If hHeader Then

              'get the current cursor position in the header
               Call GetCursorPos(pt)
               Call ScreenToClient(hHeader, pt)
               
              'get the header's hit-test info
               With HTI
                  .flags = HHT_ONHEADER Or HHT_ONDIVIDER
                  .pt = pt
               End With
   
               Call SendMessage(hHeader, HDM_HITTEST, 0&, HTI)
                     
              'react to the HDN_* code
               Select Case nm.code
            
                  Case HDN_ENDTRACK
                     List1.AddItem _
                           "HDN_ENDTRACK" & _
                           vbTab & vbTab & _
                           pt.X & vbTab & pt.Y
                     
                  Case HDN_BEGINTRACK
                     List1.AddItem _
                           "HDN_BEGINTRACK" & _
                           vbTab & _
                           "(attempting to) resize " & HTI.iItem
                     
                    'if this is the divider after the third
                    'header, prevent resizing by passing 1
                    'as the result of the WindowProc
                     If HTI.iItem = 2 Then WindowProc = 1: Exit Function

                  Case HDN_ITEMCHANGING
                     List1.AddItem _
                           "HDN_ITEMCHANGING" & _
                           vbTab & pt.X & vbTab & pt.Y
                  
                  Case HDN_BEGINDRAG
                     List1.AddItem _
                           "HDN_BEGINDRAG" & _
                           vbTab & _
                           "Begin header " _
                           & HTI.iItem & _
                           " drag"
                  
                  Case HDN_ENDDRAG
                     List1.AddItem _
                           "HDN_ENDDRAG" & _
                           vbTab & vbTab & _
                           "End header " & _
                           HTI.iItem & " drag"
                  
                  Case HDN_DIVIDERDBLCLICK
                     List1.AddItem _
                           "HDN_DIVIDERDBLCLICK" & _
                           vbTab & _
                           " at item: " & _
                           HTI.iItem
                    
                  Case NM_RCLICK
                     List1.AddItem _
                           "NM_RCLICK" & _
                           vbTab & vbTab & _
                           " on item: " & _
                           HTI.iItem
                  
                  Case HDN_ITEMCLICK
                     List1.AddItem _
                           "HDN_ITEMCLICK" & _
                           vbTab & vbTab & _
                           " on item: " & _
                           HTI.iItem
                     
                  Case Else
               End Select
               
            End If 'If hHeader Then
         
         Case Else
      
      End Select  'Select Case msg
   
   End If  'If hwnd = ListView1.hwnd

   WindowProc = CallWindowProc(GetProp(hwnd, _
                               "OldWindowProc"), _
                               hwnd, msg, wp, lp)
            
  'keep the last list entry in view
   List1.ListIndex = List1.ListCount - 1

End Function


Private Sub Command1_Click()

   Call HookWindow(ListView1.hwnd, Me)
   
   Command1.Caption = "Subclassed!"
   Command1.Enabled = False
   Label1.Caption = "Click, drag and double click the header and column dividers"
   
End Sub


Private Sub Command2_Click()

   Unload Me
   
End Sub


Private Sub Form_Load()

  'assure that the common control library is loaded
   Call IsNewComctl32(ICC_LISTVIEW_CLASSES)

End Sub


Private Sub Form_Unload(Cancel As Integer)

   Call UnhookWindow(ListView1.hwnd)

End Sub
 Comments
Run the project, press Comand1, and click, drag or resize the headers. Information about the action is relayed in the listbox. Don't forget that you can not press the VB Stop button while subclassed.

 
 

PayPal Link
Make payments with PayPal - it's fast, free and secure!

 
 
 
 

Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy

 

Hit Counter