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]