Visual Basic Common Control API Routines
WM_NOTIFY: Track Highlighted ListView Column Width Changes via Subclassing
     
Posted:   Wednesday February 20, 2002
Updated:   Monday December 26, 2011
     
Applies to:   VB6, or VB5 using APIs (not demonstrated)
Developed with:   VB6, Windows XP
OS restrictions:   None
Author:   VBnet - Randy Birch
     
Related:  

Pure VB: Create a Ledger-Style Listview Report Background
Pure VB: Create a Ledger-Style Listview Report Background with Custom Height
Pure VB: Highlight a Listview Report Column

     
 Prerequisites
Visual Basic 6. Visual Basic 5 users can not access the listview's picture property without using APIs: see SendMessage: Add a Background Image to a ListView

This is a modification of the code at Pure VB: Highlight a Listview Report Column to add subclassing of the listview control to allow tracking of ColumnHeader adjustments to maintain the correct column width as the columns are resized. For a complete description of the techniques used, see the related links above.
 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.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' *************************************************************************
'  Copyright (C)1997 Karl E. Peterson and Zane Thomas, All Rights Reserved
'  Distributed by Mabry Software, http://www.mabry.com
' *************************************************************************
'  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.
' *************************************************************************
Option Explicit

'windows constants
Private Const GWL_WNDPROC  As Long = (-4)
Private Const GWL_STYLE As Long = (-16)
Private Const WM_USER   As Long = &H400
Private Const WM_SIZE   As Long = &H5

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

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 GetWindowLong Lib "user32" _
   Alias "GetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex 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


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 command buttons (Command1), a picture box (Picture1), a combo (Combo1) and a listview (Listview1) to a form.  An imagelist is optional - if used add at least one 16x16 icon and set the correct Enum parameter in the load event (change LoadData sizeNone to LoadData sizeIcon).  Add the following code:

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.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private hHeader As Long   'handle to the listview columnheader

Private Enum ImageSizingTypes
   [sizeNone] = 0
   [sizeCheckBox]
   [sizeIcon]
End Enum

Private Enum LedgerColours
  vbledgerWhite = &HF9FEFF
  vbLedgerGreen = &HD0FFCC
  vbLedgerYellow = &HE1FAFF
  vbLedgerRed = &HE1E1FF
  vbLedgerGrey = &HE0E0E0
  vbLedgerBeige = &HD9F2F7
  vbLedgerSoftWhite = &HF7F7F7
  vbledgerPureWhite = &HFFFFFF
End Enum

'Below used for listview column auto-resizing
Private Const LVM_FIRST As Long = &H1000
Private Const LVM_SETCOLUMNWIDTH As Long = (LVM_FIRST + 30)
Private Const LVSCW_AUTOSIZE As Long = -1
Private Const LVSCW_AUTOSIZE_USEHEADER As Long = -2

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

'listview, header
Private Const ICC_LISTVIEW_CLASSES  As Long = &H1
Private Const LVM_GETHEADER = (LVM_FIRST + 31)
Private Const LVM_GETCOLUMNWIDTH = (LVM_FIRST + 29)

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

'notify messages
Private Const HDN_FIRST As Long = -300&  'header
Private Const HDN_ITEMCHANGING As Long = (HDN_FIRST - 0)
Private Const WM_NOTIFY As Long = &H4E&


Private Sub Form_Load()
  
   Command1.Caption = "Highlight Column"
   
   With Combo1
      .AddItem 1
      .AddItem 2
      .AddItem 3
      .AddItem 4
      .AddItem 5
      .ListIndex = 0
   End With
      
   LoadData sizeNone  'change to sizeIcon if using an imagelist
   
   Call HookWindow(ListView1.hwnd, Me)
   
   hHeader = SendMessage(ListView1.hwnd, LVM_GETHEADER, 0&, ByVal 0&)
   
   With Picture1
      .AutoRedraw = False       'clear/reset picture
      .Height = 1
      .AutoRedraw = True        'assure image draws
      .BorderStyle = vbBSNone   'other attributes
      .ScaleMode = vbTwips
      .Top = Form1.Top - 10000  'move it _way_ off screen
      .Visible = False
      .Height = 1               'only need a 1 pixel high picture
      .Width = Screen.Width
   End With
   
End Sub


Friend Function WindowProc(hwnd As Long, _
                           msg As Long, _
                           wp As Long, _
                           lp As Long) As Long
   
'**************************************
'Subclassing
'**************************************
   
  Static nm As NMHDR
  
   If hwnd = ListView1.hwnd Then
  
      Select Case msg
         Case WM_NOTIFY
         
           'Pass along to default window procedure and
           'het the notification message and the
           'the hwnd of the header
            WindowProc = CallWindowProc(GetProp(hwnd, "OldWindowProc"), _
                                        hwnd, msg, wp, lp)
            Call CopyMemory(nm, ByVal lp, Len(nm))
            
            If hHeader Then
              'react to the HDN_ code
               Select Case nm.code

                  Case HDN_ITEMCHANGING
                     Call SetHighlightColumn(ListView1, _
                                             vbLedgerRed, _
                                             vbledgerPureWhite, _
                                             Combo1.List(Combo1.ListIndex), _
                                             sizeNone)
               
                  Case Else
               End Select
            End If 'If hHeader
         
         Case Else
      
      End Select
   
   End If  'If hwnd 

   WindowProc = CallWindowProc(GetProp(hwnd, "OldWindowProc"), _
                               hwnd, msg, wp, lp)
            
End Function


Private Sub Command1_Click()

   With ListView1
      .Visible = False
      .Checkboxes = False
      .FullRowSelect = True
      Call SetHighlightColumn(ListView1, _
                              vbLedgerRed, _
                              vbledgerPureWhite, _
                              Combo1.List(Combo1.ListIndex), _
                              sizeNone)
      
      .Refresh
      .Visible = True            'Restore visibility

   End With

End Sub


Private Sub SetHighlightColumn(lv As ListView, _
                               clrHighlight As LedgerColours, _
                               clrDefault As LedgerColours, _
                               nColumn As Long, _
                               nSizingType As ImageSizingTypes)

   Dim cnt     As Long  'counter
   Dim cl      As Long  'columnheader left
   Dim cw      As Long  'columnheader width
         
   On Local Error GoTo SetHighlightColumn_Error
   
   If lv.View = lvwReport Then
          
     'set up the picture box properties
      With Picture1
        .BackColor = clrDefault
            
        'draw a box in the highlight colour
        'at location of the column passed
         cl = ListView1.ColumnHeaders(nColumn).Left
         cw = ListView1.ColumnHeaders(nColumn).Left + _
              ListView1.ColumnHeaders(nColumn).Width
         Picture1.Line (cl, 0)-(cw, 210), clrHighlight, BF
         
      End With  'Picture1
     
     'set the lv picture to the
     'Picture1 image
      lv.Picture = Picture1.Image
      
   Else
    
      lv.Picture = Nothing
        
   End If  'lv.View = lvwReport

SetHighlightColumn_Exit:
On Local Error GoTo 0
Exit Sub
    
SetHighlightColumn_Error:

  'clear the listview's picture and exit
   With lv
      .Picture = Nothing
      .BackColor = clrDefault
   End With
   
   Resume SetHighlightColumn_Exit
    
End Sub


Private Sub LoadData(nSizingType As ImageSizingTypes)

   Dim cnt As Long
   Dim itmX As ListItem
   
   With ListView1
      .ListItems.Clear
      .ColumnHeaders.Clear
      .ColumnHeaders.Add , , "Number"
      .ColumnHeaders.Add , , "Time"
      .ColumnHeaders.Add , , "Mode"
      .ColumnHeaders.Add , , "State"
      .ColumnHeaders.Add , , "Warnings"
      .View = lvwReport
      .Sorted = False
      .PictureAlignment = lvwTile
   End With
   
  'Create some fake data
   For cnt = 1 To 100
   
      Set itmX = Form1.ListView1.ListItems.Add(, , Format$(cnt, "###"))

      itmX.SubItems(1) = "Weld process"
      itmX.SubItems(2) = "T-manual"
      
      If cnt Mod 2 = 0 Then
         itmX.SubItems(2) = "Auto detect"
      End If
      
      If cnt Mod 3 = 0 Then
         itmX.SubItems(4) = "Trouble at " & Format$(Time, "hh:mm:ss am/pm")
         itmX.SubItems(3) = "Stopped"
         If nSizingType = sizeIcon Then itmX.SmallIcon = 1
      End If
         
   Next

  'Now that the control contains data, this
  'causes the columns to resize to fit the items
   Call lvAutosizeControl(Form1.ListView1)
   
End Sub


Private Sub lvAutosizeControl(lv As ListView)

   Dim col2adjust As Long

  'Size each column based on the maximum of
  'EITHER the columnheader text width, or,
  'if the items below it are wider, the
  'widest list item in the column
   For col2adjust = 0 To lv.ColumnHeaders.Count - 1
   
      Call SendMessage(lv.hwnd, _
                       LVM_SETCOLUMNWIDTH, _
                       col2adjust, _
                       ByVal LVSCW_AUTOSIZE_USEHEADER)

   Next
   
   
End Sub

Private Sub Form_Unload(Cancel As Integer)

   Call UnhookWindow(ListView1.hwnd)

End Sub
 Comments
 

 
 

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