Option Explicit
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongLong
#Else
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hUF As LongPtr, ByVal gaFlags As Long) As LongPtr
Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hClient As LongPtr, ByVal wFlag As Long) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hClient As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As LongPtr
Private Declare PtrSafe Function ObjectFromLresult Lib "oleacc" (ByVal lResult As LongPtr, riid As Any, ByVal wParam As LongPtr, ppvObject As Any) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare Function GetAncestor Lib "user32" (ByVal hUF As LongPtr, ByVal gaFlags As Long) As LongPtr
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hClient As LongPtr, ByVal wFlag As Long) As LongPtr
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hClient As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As LongPtr
Private Declare Function ObjectFromLresult Lib "oleacc" (ByVal lResult As LongPtr, riid As Any, ByVal wParam As LongPtr, ppvObject As Any) As Long
#End If
#If Win64 Then
Private Const NULL_PTR = 0^
#Else
Private Const NULL_PTR = 0&
#End If
Private Enum SCROLL_DIRECTION
Forward
Backward
End Enum
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type Msg
hwnd As LongPtr
message As Long
wParam As LongPtr
lParam As LongPtr
time As Long
pt As POINTAPI
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0& To 7&) As Byte
End Type
Private bLooping As Boolean
Public Property Let EnableMouseWheelScroll(ByVal Form As Object, ByVal vNewValue As Boolean)
Dim oCtrlEvents As CControlEvents
Set oCtrlEvents = New CControlEvents
Call oCtrlEvents.HookControls(Form, True)
End Property
Public Sub MonitorMouseWheel(Optional ByVal bDummy As Boolean)
If bLooping = False Then
Call MonitorWheel
End If
End Sub
Private Sub MonitorWheel()
Const WHEEL_DELTA = 120&, MK_CONTROL = &H8, WM_MOUSEWHEEL = &H20A, SPI_GETWHEELSCROLLLINES = &H68
Const PM_NOREMOVE = &H0, GA_ROOT = 2&
Dim lDelta As Integer, lAccumulatedDelta As Long, lRotations As Long
Dim lVKey As Integer, lWheelScrollLines As Long
Dim hwnd As LongPtr
Dim oForm As Object, oPrevForm As Object
Dim tMsg As Msg, tCurPos As POINTAPI
Dim X As Long, Y As Long
Do
On Error Resume Next
Application.EnableCancelKey = xlDisabled
bLooping = True
Call GetCursorPos(tCurPos)
#If Win64 Then
Dim lPt As LongLong
Call CopyMemory(lPt, tCurPos, LenB(lPt))
hwnd = WindowFromPoint(lPt)
#Else
hwnd = WindowFromPoint(tCurPos.X, tCurPos.Y)
#End If
Set oForm = HwndToDispatch(GetAncestor(hwnd, GA_ROOT))
Call IUnknown_GetWindow(oForm, VarPtr(hwnd))
If Not (oPrevForm Is Nothing) And Not (oPrevForm Is oForm) Then
Set oForm = oPrevForm
Exit Do
End If
If hwnd Then
Call WaitMessage
If PeekMessage(tMsg, hwnd, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE) Then
Call ScreenToClient(hwnd, tMsg.pt)
X = tMsg.pt.X: Y = tMsg.pt.Y
lDelta = HiWord(tMsg.wParam)
lVKey = LoWord(tMsg.wParam)
If lDelta * lAccumulatedDelta > 0& Then
lAccumulatedDelta = lAccumulatedDelta + lDelta
Else
lAccumulatedDelta = lDelta
End If
If SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0&, lWheelScrollLines, 0&) = 0& Then
lWheelScrollLines = 3&
End If
lRotations = lAccumulatedDelta \ lDelta
lRotations = IIf(lAccumulatedDelta > 0&, lRotations, -(lRotations))
Call UserForm_WheelScroll_Event _
(oForm, X, Y, lRotations, lWheelScrollLines, _
IIf(lAccumulatedDelta > 0&, Forward, Backward), CBool(lVKey = MK_CONTROL))
End If
End If
Set oPrevForm = oForm
DoEvents
Loop
Set oForm = Nothing
Set oPrevForm = Nothing
bLooping = False
End Sub
Private Function HwndToDispatch(ByVal hwnd As LongPtr) As Object
Const WM_GETOBJECT = &H3D&
Const OBJID_CLIENT = &HFFFFFFFC
Const GW_CHILD = 5&
Const S_OK = 0&
Const IID_IDISPATCH = "{00020400-0000-0000-C000-000000000046}"
Dim uGUID As GUID
Dim oForm As Object
Dim hClient As LongPtr, lResult As LongPtr
hClient = GetNextWindow(hwnd, GW_CHILD)
lResult = SendMessage(hClient, WM_GETOBJECT, NULL_PTR, ByVal OBJID_CLIENT)
If lResult Then
If IIDFromString(StrPtr(IID_IDISPATCH), uGUID) = S_OK Then
If ObjectFromLresult(lResult, uGUID, NULL_PTR, oForm) = S_OK Then
If Not oForm Is Nothing Then
Set HwndToDispatch = oForm
End If
End If
End If
End If
End Function
Private Function HiWord(Param As LongPtr) As Integer
Call CopyMemory(HiWord, ByVal VarPtr(Param) + 2&, 2&)
End Function
Private Function LoWord(Param As LongPtr) As Integer
Call CopyMemory(LoWord, ByVal VarPtr(Param), 2&)
End Function
'________________________________________ MOUSEWHEEL SCROLL PSEUDO-EVENT __________________________________
Private Sub UserForm_WheelScroll_Event( _
ByVal Form As Object, _
ByVal XPix As Long, _
ByVal YPix As Long, _
ByVal WheelRotations As Long, _
ByVal WheelScrollLines As Long, _
ByVal ScrollDirection As SCROLL_DIRECTION, _
ByVal CtrlKeyPressed As Boolean _
)
With Form
If CtrlKeyPressed = False Then
.ScrollTop = .ScrollTop + IIf(ScrollDirection = Backward, WheelScrollLines, -WheelScrollLines)
Else
.ScrollLeft = .ScrollLeft + IIf(ScrollDirection = Backward, WheelScrollLines, -WheelScrollLines)
End If
.Caption = "[XPix: " & XPix & "] [YPix: " & YPix & "]" & Space(2) & _
IIf(ScrollDirection = Backward, "[Backward]", "[Forward]") & Space(2) & _
IIf(CtrlKeyPressed, "[Horiz Scroll]", "[Vert Scroll]") & Space(2) & _
"[Rotations=" & WheelRotations & "]"
End With
End Sub