RB Smissaert
2005-06-01 16:43:19 UTC
Trying to use the Windows API to make a listbox on a VBA userform scroll
with the mousewheel.
I got this code from Jim Rech that works perfectly fine when the userform is
loaded as a normal
modal userform (vbModal). When the userform however is loaded as modeless
userform (vbModeless)
it crashes even when just loading the form.
I know this is not really VB territory, but I thought there would be more
chance getting some insight in
this in the API group than in a VBA group.
Thanks for any advice.
RBS
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
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
with the mousewheel.
I got this code from Jim Rech that works perfectly fine when the userform is
loaded as a normal
modal userform (vbModal). When the userform however is loaded as modeless
userform (vbModeless)
it crashes even when just loading the form.
I know this is not really VB territory, but I thought there would be more
chance getting some insight in
this in the API group than in a VBA group.
Thanks for any advice.
RBS
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
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