AW: @Nepumuk
03.09.2021 20:10:41
Nepumuk
Hallo,
im UserForm:
Private Sub Lst_Treffer_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call HookMouse(Me, Lst_Treffer)
End Sub
Im Modul:
Option Explicit
Option Private Module
Private Declare PtrSafe Function GetWindowLongPtrA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32.dll" ( _
ByVal point As LongLong) As LongPtr
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32.dll" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As LongPtr)
Private Declare PtrSafe Function SetWindowsHookExA Lib "user32.dll" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32.dll" ( _
ByVal hHook As LongPtr, _
ByVal ncode As Long, _
ByVal wParam As LongPtr, _
ByRef lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32.dll" ( _
ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetKeyState Lib "user32.dll" ( _
ByVal nVirtKey As Long) As Integer
Private Declare PtrSafe Function PostMessageA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Type POINTAPI
XY As LongLong
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
Private Const WH_MOUSE_LL As Long = 14&
Private Const WM_MOUSEWHEEL As LongPtr = &H20A
Private Const HC_ACTION As Long = 0&
Private Const GWL_HINSTANCE As Long = -6&
Private Const WM_KEYDOWN As Long = &H100
Private Const SCROLL_DOWN As LongPtr = &H780000
Private Const GC_CLASSNAMEUSERFORM As String = "ThunderDFrame"
Private llngptrMouseHook As LongPtr
Private llngptrControlHwnd As LongPtr
Private llngPage As Long
Private lblnHook As Boolean
Private lobjScrollObject As Object
Public Sub HookMouse(ByRef probjUserform As Object, ByRef probjScrollObject As Object, Optional ByVal opvlngPage As Long)
Dim lngptrHinstance As LongPtr
Dim lngptrFormHwnd As LongPtr
Dim lngptrHwndUnderCursor As LongPtr
Dim udtPoint As POINTAPI
llngPage = opvlngPage
Call GetCursorPos(udtPoint)
lngptrHwndUnderCursor = WindowFromPoint(udtPoint.XY)
If llngptrControlHwnd lngptrHwndUnderCursor Then
Call UnhookMouse
Set lobjScrollObject = probjScrollObject
llngptrControlHwnd = lngptrHwndUnderCursor
lngptrFormHwnd = FindWindowA(GC_CLASSNAMEUSERFORM, probjUserform.Caption)
lngptrHinstance = GetWindowLongPtrA(lngptrFormHwnd, GWL_HINSTANCE)
If Not lblnHook Then
llngptrMouseHook = SetWindowsHookExA(WH_MOUSE_LL, AddressOf MouseProc, lngptrHinstance, 0&)
lblnHook = llngptrMouseHook 0
End If
End If
End Sub
Public Sub UnhookMouse()
If lblnHook Then
Call UnhookWindowsHookEx(llngptrMouseHook)
Set lobjScrollObject = Nothing
llngptrMouseHook = 0
llngptrControlHwnd = 0
lblnHook = False
End If
End Sub
Private Function MouseProc(ByVal pvlngCode As Long, ByVal pvlngptrParam As LongPtr, ByRef prudtParam As MOUSEHOOKSTRUCT) As LongPtr
Dim lngptrHwndUnderCursor As LongPtr
On Error GoTo err_exit
If pvlngCode = HC_ACTION Then
lngptrHwndUnderCursor = WindowFromPoint(prudtParam.pt.XY)
If lngptrHwndUnderCursor = llngptrControlHwnd Then
If pvlngptrParam = 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 = SCROLL_DOWN 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 = SCROLL_DOWN Then
Call PostMessageA(llngptrControlHwnd, WM_KEYDOWN, vbKeyLeft, 0)
Else
Call PostMessageA(llngptrControlHwnd, 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 = SCROLL_DOWN Then
If .ScrollTop > 0 Then
.ScrollTop = .ScrollTop - 30
Else
.ScrollTop = 0
End If
Else
.ScrollTop = .ScrollTop + 30
End If
Else
If prudtParam.hwnd = SCROLL_DOWN 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 = SCROLL_DOWN Then
If .ScrollTop > 0 Then
.ScrollTop = .ScrollTop - 30
Else
.ScrollTop = 0
End If
Else
.ScrollTop = .ScrollTop + 30
End If
Else
If prudtParam.hwnd = SCROLL_DOWN 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(llngptrMouseHook, pvlngCode, pvlngptrParam, ByVal prudtParam)
Exit Function
err_exit:
Call UnhookMouse
End Function
Gruß
Nepumuk