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