|
|
||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Visual Basic Subclassing Routines WM_VSCROLL: Subclassing Listview Scrollbar Messages |
||
Posted: | Tuesday August 29, 2000 | |
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. |
|
When
it is necessary for your app to maintain synchronization between two or more Listview controls - or two or more List boxes for that
matter - as the user interacts with the primary control's scrollbar, subclassing must be used in order to
track the user's
interaction and reflect that action in the other control(s).
This demo shows the minimum code you need to safely subclass a ListView control and, as the user manipulates the vertical scrollbar of ListView1, cause the same scrolling actions in the ListView2 control. Only Listview1 is actually subclassed - Listview2 simply receives normal SendMessage messages and processes them intrinsically without further intervention or code. Despite the mass of code below the actual code to do this is a one-liner within the subclassing WindowProc - a simple SendMessage call passing WM_VSCROLL with the type of scrolling action to perform as the wParam message (a single line up or down, a page up or down, or thumb tracking). Normally, were this method being employed to echo changes in a standard Windows' scrollbar the lParam parameter of the WindowProc procedure would receive the hwnd of the scrollbar being manipulated. But since ListView2's scrollbar is a child window of the listview control, lParam is not used. The listview control API also has its own scroll message - LVM_SCROLL - which is also fired in response to a scrollbar action. However this message is useless to us as it is targeted more for the large and small icon views of the control. In those views, to scroll a ListView using LVM_SCROLL in a SendMessage call you specify the number of pixels to scroll, not the number of lines or pages. To scroll using LVM_SCROLL in Report view, you specify the line height in pixels. In report view, if the value to scroll exceeds a line height in pixels two lines or more will scroll. If the value is too small, then no scrolling occurs. Because of this, using the standard windows message is easier than using the listview message in report view. Also included in the subclassing code below are some additional API methods that are not required for the procedure to work, but which demonstrate how to receive (and set) scrollbar information using GetScrollbarInfo and SetScrollbarInfo. Also shown are messages that could be used to change the action performed so that the mirrored control reacts differently than the subclassed control. And finally, just for fun, the code also demonstrates how to use subclassing to scroll the mirrored control, but negate the actual scrolling of the subclassed control. While not especially useful, it demonstrates how to trap and kill a scroll message. Not covered in this demo is maintaining the mirrored ListView's top index when the keyboard is used to scroll the subclassed control's contents. Subclassing is provided via Karl Peterson's HookMe subclassing method. Remember you can't hit the VB Stop button when subclassed -- use the Done or 'X' button instead to invoke the Unload code. |
BAS Module 1 Code: lvheader.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. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'listview, header
Public Const ICC_LISTVIEW_CLASSES As Long = &H1
Public Type tagINITCOMMONCONTROLSEX 'icc
dwSize As Long 'size of this structure
dwICC As Long 'which classes to be initialized
End Type
Public Declare Sub InitCommonControls Lib "comctl32.dll" ()
Public Declare Function InitCommonControlsEx Lib "comctl32.dll" _
(lpInitCtrls As tagINITCOMMONCONTROLSEX) As Boolean
'Returns True if the current working version of Comctl32.dll
'supports IE3 styles & msgs. Returns False if old version.
'Also ensures that the Comctl32.dll library is loaded for use.
Public Function IsNewComctl32(dwFlags As Long) As Boolean
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
|
BAS Module 2 Code: HookMe.bas |
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. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '************************************************************************* ' 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 'MUST be the correct name of the form 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 two Command buttons to the form (Command1 & Command2), as well as a listbox (List1). Add two ListView controls (ListView1 & ListView2). Add some ColumnHeaders to the ListView and set both to report mode. Important - name the form frmMain to match the HookMe code above, and then add the following code: |
|
Option Explicit
Private Const WM_VSCROLL = &H115
Private Const SB_VERT = 1
Private Const SIF_RANGE = &H1
Private Const SIF_PAGE = &H2
Private Const SIF_POS = &H4
Private Const SIF_DISABLENOSCROLL = &H8
Private Const SIF_TRACKPOS = &H10
Private Const SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS)
Private Const SB_LINEUP = 0
Private Const SB_LINEDOWN = 1
Private Const SB_PAGEUP = 2
Private Const SB_PAGEDOWN = 3
Private Const SB_THUMBPOSITION = 4
Private Const SB_THUMBTRACK = 5
Private Const SB_TOP = 6
Private Const SB_BOTTOM = 7
Private Const SB_ENDSCROLL = 8
Private Type SCROLLINFO
cbSize As Long
fMask As Long
nMin As Long
nMax As Long
nPage As Long
nPos As Long
nTrackPos As Long
End Type
Private Declare Function GetScrollInfo Lib "user32" _
(ByVal hWnd As Long, _
ByVal n As Long, _
lpScrollInfo As SCROLLINFO) As Long
Private Declare Function SetScrollInfo Lib "user32" _
(ByVal hWnd As Long, _
ByVal n As Long, _
lpcScrollInfo As SCROLLINFO, _
ByVal fRedraw As Long) As Long
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
Private Sub Form_Load()
'assure the common control library is loaded
Call IsNewComctl32(ICC_LISTVIEW_CLASSES)
Dim x As Integer
'Add a few items to the listviews.
'Nothing pretty or efficient here!
Do
x = x + 1
ListView1.ListItems.Add x, , "Item " & CStr(x)
ListView2.ListItems.Add x, , "Item " & CStr(x)
Loop While x < 50
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call UnhookWindow(ListView1.hwnd)
End Sub
Friend Function WindowProc(hwnd As Long, _
msg As Long, _
wParam As Long, _
lParam As Long) As Long
'**************************************
'Subclassing
'**************************************
Dim sci As SCROLLINFO
If hWnd = ListView1.hWnd Then
Select Case msg
'message of interest
Case WM_VSCROLL
' '------------------------------------------
' 'this block (between the dashed lines)
' 'demonstrates obtaining scrollbar information
' 'and can actually be commented out without
' 'impacting the method!
'
' 'fill a SCROLLINFO structure to receive
' 'scrollbar data from the subclassed
' 'listview and call the GetScrollInfo API
' With sci
' .cbSize = Len(sci)
' .fMask = SIF_ALL
' End With
'
' Call GetScrollInfo(hWnd, SB_VERT, sci)
'
' 'Information only: shows the values
' 'returned by the API as tabbed list items
' With List1
' .AddItem sci.nMin & vbTab & _
' sci.nMax & vbTab & _
' sci.nPage & vbTab & _
' sci.nPos & vbTab & _
' sci.nTrackPos & vbTab & _
' wParam & vbTab & lParam
' .TopIndex = .NewIndex
' End With
'
' 'If you wanted to provide any special
' 'capability, ie if a user enacted a line up but
' 'you wanted to translate that into a page down,
' 'etc, you could do that here.
' Select Case wParam
' Case SB_LINEUP: '0
' 'wParam = SB_LINEDOWN 'tweak the action!
' Case SB_LINEDOWN: '1
' Case SB_PAGEUP: '2
' Case SB_PAGEDOWN: '3
' Case SB_THUMBPOSITION: '4
' Case SB_THUMBTRACK: '5
' Case SB_TOP: '6
' Case SB_BOTTOM: '7
' Case SB_ENDSCROLL: '8
' End Select
'
' 'SetScrollInfo sets the target window's
' 'scrollbar's characteristics to match the
' 'source. Where a value is outside a valid
' 'range, (ie if the source returned 100 for
' 'nMax, but the target only had 50 items,
' 'the target will set the nMax number to 50).
' Call SetScrollInfo(ListView2.hWnd, SB_VERT, sci, 1&)
' '------------------------------------------
'The actual scrolling method - a one-liner!
'On entering this routine, wParam
'contains one of the SB_xxx messages
'listed above. By passing it directly
'to the mirrored listview, the mirror
'tracks as the subclassed listview
'is scrolled.
Call SendMessage(ListView2.hWnd, _
WM_VSCROLL, _
wParam, _
ByVal 0&)
'If you want to disable scrolling in the
'subclassed listview, but want the mirrored
'listview to scroll as if its scrollbar had
'been used, uncomment the two lines below.
' WindowProc = 0
' Exit Function
Case Else
End Select
End If
'pass on to the default window procedure
WindowProc = CallWindowProc(GetProp(hWnd, "OldWindowProc"), _
hWnd, msg, _
wParam, lParam)
End Function
Private Sub Command1_Click()
Call HookWindow(ListView1.hwnd, Me)
Command1.Caption = "Subclassed!"
Command1.Enabled = False
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
|
Comments |
Run the project, press Comand1, and scroll the subclassed
listview. The second listview will mirror the scrollbar action. Scrollbar information from GetScrollbarInfo will be relayed in the
listbox if the code between the dashed lines has been uncommented.
Incidentally, this same SendMessage call can also be used to scroll a listview programmatically. To demo this, add a third command button to the form (Command3) with the following: Private Sub Command3_Click() Call SendMessage(ListView1.hwnd, WM_VSCROLL, SB_PAGEDOWN, ByVal 0&) End Sub If this code is called when the subclassing above is activated, both listview controls will scroll. |
|
|
|
|||||
|
|||||
|
|||||
Copyright ©1996-2011 VBnet and Randy Birch. All Rights Reserved. |