AW: Scrollen in CB mit Mausrad
28.05.2021 19:59:16
Nepumuk
Hallo reiner,
hier eine Version die unter Excel 2007 laufen sollte, aber ohne Garantie:
Code:
[Cc][+][-]
Option Explicit
Option Private Module
Private Declare Function GetWindowLongA Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function WindowFromPoint Lib "user32.dll" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long)
Private Declare Function SetWindowsHookExA Lib "user32.dll" ( _
ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32.dll" ( _
ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32.dll" ( _
ByVal hHook As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetKeyState Lib "user32.dll" ( _
ByVal nVirtKey As Long) As Integer
Private Declare Function PostMessageA Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
Private Const WH_MOUSE_LL As Long = 14&
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0&
Private Const GWL_HINSTANCE As Long = -6&
Private Const WM_KEYDOWN As Long = &H100
Private llngMouseHook As Long
Private llngControlHwnd As Long
Private llngPage As Long
Private lblnHook As Boolean
Private lobjScrollObject As Object
Public Sub HookMouse(ByRef probjScrollObject As Object, Optional ByVal opvlngPage As Long)
Dim lngHinstance As Long
Dim lngHwndUnderCursor As Long
Dim udtPoint As POINTAPI
llngPage = opvlngPage
Call GetCursorPos(udtPoint)
lngHwndUnderCursor = WindowFromPoint(udtPoint.X, udtPoint.Y)
If llngControlHwnd <> lngHwndUnderCursor Then
Call UnhookMouse
Set lobjScrollObject = probjScrollObject
llngControlHwnd = lngHwndUnderCursor
lngHinstance = GetWindowLongA(llngControlHwnd, GWL_HINSTANCE)
If Not lblnHook Then
llngMouseHook = SetWindowsHookExA(WH_MOUSE_LL, AddressOf MouseProc, lngHinstance, 0&)
lblnHook = llngMouseHook <> 0
End If
End If
End Sub
Public Sub UnhookMouse()
If lblnHook Then
Call UnhookWindowsHookEx(llngMouseHook)
Set lobjScrollObject = Nothing
llngMouseHook = 0
llngControlHwnd = 0
lblnHook = False
End If
End Sub
Private Function MouseProc(ByVal pvlngCode As Long, ByVal pvlngParam As Long, ByRef prudtParam As MOUSEHOOKSTRUCT) _
As Long
Dim lngHwndUnderCursor As Long
On Error GoTo err_exit
If pvlngCode = HC_ACTION Then
lngHwndUnderCursor = WindowFromPoint(prudtParam.pt.X, prudtParam.pt.Y)
If lngHwndUnderCursor = llngControlHwnd Then
If pvlngParam = WM_MOUSEWHEEL Then
If TypeOf lobjScrollObject Is MSForms.ListBox Or TypeOf lobjScrollObject Is MSForms.ComboBox Then
With lobjScrollObject
If GetKeyState(vbKeyControl) >= 0 Then
If prudtParam.hwnd > 0 Then
If .TopIndex > 0 Then
If .TopIndex > 3 Then
.TopIndex = .TopIndex - 3
Else
.TopIndex = 0
End If
End If
Else
.TopIndex = .TopIndex + 3
End If
Else
If TypeOf lobjScrollObject Is MSForms.ListBox Then
If prudtParam.hwnd > 0 Then
Call PostMessageA(llngControlHwnd, WM_KEYDOWN, vbKeyLeft, 0)
Else
Call PostMessageA(llngControlHwnd, WM_KEYDOWN, vbKeyRight, 0)
End If
End If
End If
End With
ElseIf TypeOf lobjScrollObject Is MSForms.MultiPage Then
With lobjScrollObject.Pages(llngPage)
If GetKeyState(vbKeyControl) >= 0 Then
If prudtParam.hwnd > 0 Then
If .ScrollTop > 0 Then
.ScrollTop = .ScrollTop - 30
Else
.ScrollTop = 0
End If
Else
.ScrollTop = .ScrollTop + 30
End If
Else
If prudtParam.hwnd > 0 Then
If .ScrollLeft > 0 Then
.ScrollLeft = .ScrollLeft - 30
Else
.ScrollLeft = 0
End If
Else
.ScrollLeft = .ScrollLeft + 30
End If
End If
End With
ElseIf TypeOf lobjScrollObject Is MSForms.UserForm Or TypeOf lobjScrollObject Is MSForms.Frame Then
With lobjScrollObject
If GetKeyState(vbKeyControl) >= 0 Then
If prudtParam.hwnd > 0 Then
If .ScrollTop > 0 Then
.ScrollTop = .ScrollTop - 30
Else
.ScrollTop = 0
End If
Else
.ScrollTop = .ScrollTop + 30
End If
Else
If prudtParam.hwnd > 0 Then
If .ScrollLeft > 0 Then
.ScrollLeft = .ScrollLeft - 30
Else
.ScrollLeft = 0
End If
Else
.ScrollLeft = .ScrollLeft + 30
End If
End If
End With
End If
Exit Function
End If
Else
Call UnhookMouse
End If
End If
MouseProc = CallNextHookEx(llngMouseHook, pvlngCode, pvlngParam, ByVal prudtParam)
Exit Function
err_exit:
Call UnhookMouse
End Function
Gruß
Neoumuk
