Option Explicit
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
#If VBA7 Then
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
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
Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Dim hMouseHook As LongPtr, hDropDown As LongPtr
#Else
Declare Function FindWindow Lib "user32" Alias "FindWindowA"(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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
Declare Function CallNextHookEx Lib "user32"(ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32"(ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
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
Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Dim hMouseHook As Long, hDropDown As Long
#End If
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Const HC_ACTION = 0
Const WM_KEYDOWN = &H100
Public Sub HookValidationList(Cell As Range)
Call RemoveHook
If HasValidateList(Cell) Then
SetTimer Application.hwnd, 0, 100, AddressOf TimerProc
Else
Call RemoveHook
End If
End Sub
Public Sub RemoveHook()
If GetProp(Application.hwnd, "MouseHook") Then
KillTimer Application.hwnd, 0
UnhookWindowsHookEx GetProp(Application.hwnd, "MouseHook")
RemoveProp Application.hwnd, "MouseHook"
End If
End Sub
Sub TimerProc()
hDropDown = FindWindow("EXCEL:", vbNullString)
If hDropDown <> 0 Then
Call RemoveHook
#If VBA7 Then
hMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.HinstancePtr, 0)
#Else
hMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, Application.Hinstance, 0)
#End If
SetProp Application.hwnd, "MouseHook", hMouseHook
End If
End Sub
#If VBA7 Then
Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, lParam As MSLLHOOKSTRUCT) As LongPtr
#Else
Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
#End If
On Error GoTo ErrHandler
If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
LowLevelMouseProc = True
If lParam.mouseData > 0 Then
Call PostMessage(hDropDown, WM_KEYDOWN, vbKeyUp, 0)
Else
Call PostMessage(hDropDown, WM_KEYDOWN, vbKeyDown, 0)
End If
Exit Function
End If
End If
If IsWindow(hDropDown) Then Call HookValidationList(ActiveCell)
ErrHandler:
If Err.Number <> 0 Then Err.Clear: RemoveHook
LowLevelMouseProc = CallNextHookEx(GetProp(Application.hwnd, "MouseHook"), nCode, wParam, ByVal lParam)
End Function
Function HasValidateList(Cell As Range) As Boolean
On Error Resume Next
HasValidateList = Cell.Validation.InCellDropdown
End Function