Printable View
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)
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.
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]
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.
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
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.