Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
#If Win64 Then
Private Type MSG
hwnd As LongLong
message As Long
wParam As LongLong
lParam As LongLong
time As Long
pt As POINTAPI
End Type
#Else
Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
#End If
#If VBA7 Then
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 PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
#Else
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, 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 PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
#End If
Private bEnable As Boolean
Public Property Let EnableWheelScroll(ByVal Enable As Boolean)
Const WM_MOUSEWHEEL = &H20A
Const WHEEL_DELTA = 120
Const PM_REMOVE = &H1
Const MK_SHIFT = &H4
Dim tMsg As MSG
Dim oTempSheet As Worksheet
bEnable = Enable
Do While bEnable
If GetActiveWindow = Application.hwnd Then
Call WaitMessage
If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
If loword(CLng(tMsg.wParam)) = MK_SHIFT Then
If (hiword(CLng(tMsg.wParam)) / WHEEL_DELTA) > 0 Or (hiword(CLng(tMsg.wParam)) = WHEEL_DELTA) Then
Set oTempSheet = ActiveSheet.Next
If oTempSheet Is Nothing Then
Set oTempSheet = Sheets(1)
End If
oTempSheet.Activate
Else
Set oTempSheet = ActiveSheet.Previous
If oTempSheet Is Nothing Then
Set oTempSheet = Sheets(Sheets.Count)
End If
oTempSheet.Activate
End If
Else
With tMsg
Call PostMessage(.hwnd, .message, .wParam, .lParam)
End With
End If
End If
End If
DoEvents
Loop
End Property
Private Function loword(DWord As Long) As Integer
If DWord And &H8000& Then
loword = DWord Or &HFFFF0000
Else
loword = DWord And &HFFFF&
End If
End Function
Private Function hiword(ByVal DWord As Long) As Integer
hiword = (DWord And &HFFFF0000) \ &H10000
End Function