AW: Bitte um Test mit 64Bit-Excel
30.08.2020 14:07:24
Nepumuk
Hallo Curly,
das ist die finale Version:
Option Explicit
Option Private Module
#If Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongPtrA" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32.dll" ( _
ByVal point As LongLong) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" ( _
ByVal hwnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32.dll" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As LongPtr
#End If
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 Type POINTAPI
X As Long
Y As Long
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 llngptrMouseHook As LongPtr
Private llngptrControlHwnd As LongPtr
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 lngptrHinstance As LongPtr
Dim lngptrHwndUnderCursor As LongPtr
Dim udtPoint As POINTAPI
llngPage = opvlngPage
Call GetCursorPos(udtPoint)
#If Win64 Then
lngptrHwndUnderCursor = WindowFromPoint(PointToLongLong(udtPoint))
#Else
lngptrHwndUnderCursor = WindowFromPoint(udtPoint.X, udtPoint.Y)
#End If
If llngptrControlHwnd <> lngptrHwndUnderCursor Then
Call UnhookMouse
Set lobjScrollObject = probjScrollObject
llngptrControlHwnd = lngptrHwndUnderCursor
lngptrHinstance = GetWindowLong(llngptrControlHwnd, 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
Set lobjScrollObject = Nothing
Call UnhookWindowsHookEx(llngptrMouseHook)
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 lngptrTempHwnd As LongPtr
On Error GoTo err_exit
If pvlngCode = HC_ACTION Then
#If Win64 Then
lngptrTempHwnd = WindowFromPoint(PointToLongLong(prudtParam.pt))
#Else
lngptrTempHwnd = WindowFromPoint(prudtParam.pt.X, prudtParam.pt.Y)
#End If
If lngptrTempHwnd = 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 > 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(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 > 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(llngptrMouseHook, pvlngCode, pvlngptrParam, ByVal prudtParam)
Exit Function
err_exit:
Call UnhookMouse
End Function
#If Win64 Then
Private Function PointToLongLong(ByRef prudtPoint As POINTAPI) As LongLong
Dim lnglngTemp As LongLong
Dim lngprtLength As LongPtr
lngprtLength = LenB(lnglngTemp)
If LenB(prudtPoint) = lngprtLength Then Call RtlMoveMemory(lnglngTemp, prudtPoint, lngprtLength)
PointToLongLong = lnglngTemp
End Function
#End If
Gruß
Nepumuk