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