AW: Scroll-Rad-Funktion der Mouse in einer Listbox
31.12.2004 12:15:55
Frank
Hi Peter,
geht schon, aber nur mit Windows API Funktionen (dann aber relativ einfach). Füge folgenden Code in ein neues Modul ein:
'---------------------------------------------------------------------------
' Created: November 2004
' Authors: Frank Kabel, Bob Phillips
'---------------------------------------------------------------------------
'Module: mListboxScrol
'Original author: Jim Rech
'Extended: Frank Kabel, Bob Phillips - test for XL97 and call custom callbac
'Purpose: Contains all code for enabling mosue wheel scrolling
'---------------------------------------------------------------------------
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
Public
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
Public
Sub UserformHook(PassedForm As UserForm, _
Cap As String)
Dim LocalHwnd As Long
Dim LocalPrevWndProc As Long
Dim cError As Long
Dim i As Long
LocalHwnd = FindWindow("ThunderDFrame", Cap)
'if Excel2000 or above use the built-in AddressOf operator to
'get a pointer to the callback function
If Val(Application.Version) > 8 Then
LocalPrevWndProc = SetWindowLong(hWnd:=LocalHwnd, _
nIndex:=GWL_WNDPROC, _
dwNewLong:=AddrOf_Callback_Routine)
Else 'use K.Getz & M.Kaplan
Function to get a pointer
LocalPrevWndProc = SetWindowLong(hWnd:=LocalHwnd, _
nIndex:=GWL_WNDPROC, _
dwNewLong:=AddrOf("WindowProc"))
End If
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 cError = 0 Then ''Avoid infinite error loop
For i = 1 To collUFHdl.Count
If collUFHdl(i) = LocalHwnd Then
collUFHdl.Remove i
collUF.Remove i
collPrevHdl.Remove i
End If
Next
cError = 1
Resume TryAgain
End If
End Sub
'---------------------------------------------------------------------------
Public
Sub UserformUnHook(UF As UserForm)
Dim i As Long
For i = 1 To collUF.Count
If UF Is collUF(i) Then Exit For
Next
''SetWindowLong LocalHwnd, GWL_WNDPROC, LocalPrevWndProc
SetWindowLong collUFHdl(i), GWL_WNDPROC, collPrevHdl(i)
collUF.Remove i
collPrevHdl.Remove i
collUFHdl.Remove i
End Sub
'---------------------------------------------------------------------------
Public
Sub MouseWheel(UF As UserForm, _
ByVal Rotation As Long, _
ByVal Btn As Long)
' Function: Scrolls listbox 1 row or a full page if Ctrl is down
Dim LinesToScroll As Long
Dim ListRows As Long
Dim Idx As Long
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
'---------------------------------------------------------------------------
' END OF CODE
'---------------------------------------------------------------------------
So und nun kannst Du einfach in der Initialisierung Deiner Uerform folgende Zeile ergänzen:
UserformHook Me, Me.Caption
das wars dann schon :-)
Gruß
Frank