Scrolling through a list box with a mouse wheel

[pcarmour]

Hi, I have a number of list boxes in my project, one with 200 rows of data, can anyone please advise how I can allow users to scroll through this list box data using their mouse scroll wheel.
Any help as always is very much appreciated.
I am working with Windows Home Premium version 6.1.7601 SP 1 Build 7601and Excel version 14.0.6123.5001 (32 bit)

[Kenneth Hobs]

http://www.xtremevbtalk.com/archive/.../t-178071.html

[pcarmour]

Hi Kenneth, Thank you for your prompt response to my question.
Yes I did read that thread and tried to create a new spread sheet/ user form/ list box using it but couldn't get my head around it. I was also rather hoping that there might have been an easier or shorter way to do it as this thread was written in July 2004 and Excel VBA has moved on dramatically since then.

[Press]

Hi,

You can try the following example:

Userform1
ListBox1
ListBox2

UserForm1
[vba]Private Sub UserForm_Initialize()
Dim Counter As Integer
For Counter = 1 To 20
ListBox1.AddItem Counter
ListBox2.AddItem Counter * 10
Next
UserformHook Me, Me.Caption
End Sub[/vba] Modulo1
[vba]Option Explicit


Private Declare Function CallWindowProc _
Lib "user32.dll" _
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 SetWindowLong _
Lib "user32.dll" _
Alias "SetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long


Private Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long


Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A


Dim collUF As New Collection
Dim collPrevHdl As New Collection
Dim collUFHdl As New Collection


Private Function WindowProc(ByVal Lwnd As Long, _
ByVal Lmsg As Long, _
ByVal Wparam As Long, _
ByVal Lparam As Long) As Long


Dim Rotation As Long
Dim Btn As Long


If Lmsg = WM_MOUSEWHEEL Then
Rotation = Wparam / 65536 ''High order word indicates direction
Btn = Abs(Wparam) And 15 ''Low order word indicates various virtual keys held down
MouseWheel collUF(CStr(Lwnd)), Rotation, Btn
WindowProc = 0 ''We handled event, no need to pass on (right?)
Else
WindowProc = CallWindowProc(collPrevHdl(CStr(Lwnd)), _
Lwnd, _
Lmsg, _
Wparam, _
Lparam)
End If

End Function


''Need both userform and its caption because Userform1.Caption is empty for some reason
Sub UserformHook(PassedForm As UserForm, Cap As String)

Dim LocalHwnd As Long
Dim LocalPrevWndProc As Long
Dim ErrCounter As Integer
Dim Counter As Integer


LocalHwnd = FindWindow("ThunderDFrame", Cap)
LocalPrevWndProc = SetWindowLong(LocalHwnd, GWL_WNDPROC, AddressOf WindowProc)

On Error GoTo DupKey ''In case Windows assigns the same handle to a subsequent userform (altho it doesn't seem to do this)...
TryAgain:
collUF.Add PassedForm, CStr(LocalHwnd)
collPrevHdl.Add LocalPrevWndProc, CStr(LocalHwnd)
collUFHdl.Add LocalHwnd
Exit Sub
DupKey:
If ErrCounter = 0 Then ''Avoid infinite error loop
For Counter = 1 To collUFHdl.Count
If collUFHdl(Counter) = LocalHwnd Then
collUFHdl.Remove Counter
collUF.Remove Counter
collPrevHdl.Remove Counter
End If
Next
ErrCounter = 1
Resume TryAgain
End If

End Sub


''Scrolls listbox 1 row or a full page if Ctrl is down
Sub MouseWheel(UF As UserForm, _
ByVal Rotation As Long, _
ByVal Btn As Long)


Dim LinesToScroll As Integer
Dim ListRows As Integer
Dim Idx As Integer


With UF
If TypeName(.ActiveControl) = "ListBox" Then
ListRows = .ActiveControl.ListCount
If Btn = 8 Then ''Ctrl
LinesToScroll = Int(.ActiveControl.Height / 10) ''Seems to work for font size 8
Else
LinesToScroll = 1
End If
If Rotation > 0 Then
'Scroll up
Idx = .ActiveControl.TopIndex - LinesToScroll
If Idx < 0 Then Idx = 0
.ActiveControl.TopIndex = Idx
Else
'Scroll down
Idx = .ActiveControl.TopIndex + LinesToScroll
If Idx > ListRows Then Idx = ListRows
.ActiveControl.TopIndex = Idx
End If
End If
End With

End Sub

Sub Test()
UserForm1.Show
End Sub[/vba]

[pcarmour]

Hi Press,
Thank you very much for looking at this.
I have entered your code into the attached test - Book2 but sorry I'm doing something wrong. Can you please check and correct it for me please.

[Press]

Hi,

Have you used: ListBox1.RowSource
You need to upgrade:
Userform1


[vba]Private Sub UserForm_Initialize()
UserformHook Me, Me.Caption
End Sub[/vba]
Test Ok Excel 2003

[pcarmour]

Hi Press, Yes I have used the Rowsource sheet1!A1:M53 in the List Box properties.
OK I have now changed the UserForm_Initialize to your new code and the list box now loads but I'm sorry to say the list box data isn't scrolling.

Just tried the test without rowsource in the listbox properties and your first initialize code and the userform loads with just column A in the listboxes but still no scrolling.