Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal length As LongPtr)
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
#End If
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MSLLHOOKSTRUCT
pt As POINTAPI
mouseData As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type
Private Const HC_ACTION = 0
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEWHEEL = &H20A
Private Const GWL_HINSTANCE = (-6)
Public Const nMyControlTypeNONE = 0
Public Const nMyControlTypeUSERFORM = 1
Public Const nMyControlTypeFRAME = 2
Public Const nMyControlTypeCOMBOBOX = 3
Public Const nMyControlTypeLISTBOX = 4
Private hhkLowLevelMouse As Long
Private udtlParamStuct As MSLLHOOKSTRUCT
Public myGblUserForm As UserForm
Public myGblControlObject As Object
Public iGblControlType As Integer
Public myGblUserFormControl As Object
#If VBA7 Then
Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
#Else
Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
#End If
CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function
#If VBA7 Then
Function LowLevelMouseProc(ByVal ncode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
Function LowLevelMouseProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
Dim iDirection As Long
On Error Resume Next
If GetForegroundWindow <> FindWindow("ThunderDFrame", myGblUserForm.Caption) Then
UnHook_Mouse
Exit Function
End If
If (ncode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
iDirection = GetHookStruct(lParam).mouseData
Call ProcessMouseWheelMovement(iDirection)
LowLevelMouseProc = True
End If
Exit Function
End If
LowLevelMouseProc = CallNextHookEx(0, ncode, wParam, ByVal lParam)
End Function
Sub Hook_Mouse()
If hhkLowLevelMouse < 1 Then
hhkLowLevelMouse = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetWindowLong(FindWindow("ThunderDFrame", myGblUserForm.Caption), GWL_HINSTANCE), 0)
End If
End Sub
Sub UnHook_Mouse()
If hhkLowLevelMouse <> 0 Then
UnhookWindowsHookEx hhkLowLevelMouse
hhkLowLevelMouse = 0
End If
End Sub
Public Sub ProcessMouseWheelMovement(ByVal iDirection As Long)
Dim i As Long
Dim iMultiplier As Long
Select Case iGblControlType
Case nMyControlTypeUSERFORM
iMultiplier = 3
If iDirection > 0 Then
For i = 1 To iMultiplier
myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineUp
Next i
Else
For i = 1 To iMultiplier
myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineDown
Next i
End If
Case nMyControlTypeFRAME
iMultiplier = 5
If iDirection > 0 Then
For i = 1 To iMultiplier
myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineUp
Next i
Else
For i = 1 To iMultiplier
myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineDown
Next i
End If
Case nMyControlTypeCOMBOBOX
With myGblControlObject
If iDirection > 0 Then
.TopIndex = .TopIndex - 1
Else
.TopIndex = .TopIndex + 1
End If
End With
Case nMyControlTypeLISTBOX
With myGblControlObject
If iDirection > 0 Then
.TopIndex = .TopIndex - 1
Else
.TopIndex = .TopIndex + 1
End If
End With
End Select
End Sub
(
