Option Explicit
' Jaafar Tribak @ MrExcel.com on 22/04/20
' Code that enables mousewheel scrolling in vba Userform ComboBoxes.
' USAGE:
' ------
' Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
' EnableMouseScroll(ComboBox1) = True
' End Sub
Private Type POINTAPI
x As Long
y As Long
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#If VBA7 Then
Private Type MSG
hwnd As LongPtr
message As Long
wParam As LongPtr
lParam As LongPtr
time As Long
pt As POINTAPI
End Type
#If Win64 Then
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd 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 GetSystemMetrics Lib "user32" (ByVal nIndex As Long) 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 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 GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDc As LongPtr) As Long
#Else
Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) 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 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 GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long
#End If
' API consts
Private Const WM_MOUSEWHEEL = &H20A
Private Const WHEEL_DELTA = 120
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const MK_LBUTTON = &H1
Private Const SM_CXVSCROLL = 2
Private Const PM_NOREMOVE = &H0
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const POINTSPERINCH As Long = 72
Private Const LINES_PER_SCROLL = 1 '<=== (LINES_PER_SCROLL):Change scroll lines value as required
Private bMonitoringMouseWheel As Boolean
Public sFeedback As String
Public Property Let EnableMouseScroll(ByVal ComboBox As Object, ByVal Enable As Boolean)
#If VBA7 Then
Static DropDownHwnd As LongPtr
Dim hwnd As LongPtr
#Else
Static DropDownHwnd As Long
Dim hwnd As Long
#End If
Dim tRect As RECT, tMsg As MSG, tCurPos As POINTAPI
Dim Low As Integer, High As Integer, i As Integer
Dim vChild As Variant, oIA As IAccessible
ComboBox.SetFocus
WindowFromAccessibleObject ComboBox, hwnd
If Not bMonitoringMouseWheel Then
bMonitoringMouseWheel = True
If Enable Then
Call UserFeedBack("Monitoring MouseWheel Messages for : (" & ComboBox.Name & ")")
Do While IsWindow(hwnd)
GetCursorPos tCurPos
If IsMouseOverListBox(tCurPos) = False Then
Exit Do
End If
#If Win64 Then
Dim lPt As LongPtr
CopyMemory lPt, tCurPos, LenB(lPt)
Call AccessibleObjectFromPoint(lPt, oIA, vChild)
#Else
Call AccessibleObjectFromPoint(tCurPos.x, tCurPos.y, oIA, vChild)
#End If
If oIA.accRole(0&) = 46 Then
tCurPos.y = tCurPos.y + PTtoPX(ComboBox.Height, False)
End If
#If Win64 Then
Dim lPt2 As LongPtr
CopyMemory lPt2, tCurPos, LenB(lPt2)
DropDownHwnd = WindowFromPoint(lPt2)
#Else
DropDownHwnd = WindowFromPoint(tCurPos.x, tCurPos.y)
#End If
WaitMessage
If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE) Then
GetClientRect DropDownHwnd, tRect
#If Win64 Then
Dim lParm As LongPtr
If IsMouseOverListBox(tMsg.pt) = True Then
If HighWord64(tMsg.wParam) = WHEEL_DELTA Then
#Else
Dim lParm As Long
If IsMouseOverListBox(tMsg.pt) = True Then
If HighWord32(tMsg.wParam) = WHEEL_DELTA Then
#End If
Call UserFeedBack("MouseWheel Scrolling (Up)")
Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
High = tRect.Top + ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
Else
Call UserFeedBack("MouseWheel Scrolling (Down)")
Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
High = tRect.Bottom - ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
End If
lParm = MakeDWord(Low, High)
For i = 1 To LINES_PER_SCROLL '<=== (LINES_PER_SCROLL):Change this scroll lines Const as required
PostMessage DropDownHwnd, WM_LBUTTONDOWN, MK_LBUTTON, lParm
PostMessage DropDownHwnd, WM_LBUTTONUP, MK_LBUTTON, lParm
Next i
End If
End If ' PeekMessage
DoEvents
Loop
bMonitoringMouseWheel = False
Call UserFeedBack("MouseWheel Monitoring Stopped.")
End If
End If
End Property
Private Function IsMouseOverListBox(ByRef CusPos As POINTAPI) As Boolean
Dim vChild As Variant, oIA As IAccessible
#If Win64 Then
Dim lPt As LongPtr
CopyMemory lPt, CusPos, LenB(lPt)
Call AccessibleObjectFromPoint(lPt, oIA, vChild)
#Else
Call AccessibleObjectFromPoint(CusPos.x, CusPos.y, oIA, vChild)
#End If
On Error Resume Next
IsMouseOverListBox = oIA.accRole(0&) = 33 Or oIA.accRole(0&) = 46
End Function
Private Sub UserFeedBack(ByVal Feedback As String)
Debug.Print Feedback
sFeedback = Feedback
End Sub
Private Function MakeDWord(ByVal loword As Integer, ByVal hiword As Integer) As Long
MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function
Private Function HighWord32(ByVal wParam As Long) As Integer
CopyMemory HighWord32, ByVal VarPtr(wParam) + 2, 2
End Function
#If Win64 Then
Private Function HighWord64(ByVal wParam As LongPtr) As Long
CopyMemory HighWord64, ByVal VarPtr(wParam) + 2, 4
End Function
#End If
Private Function ScreenDPI(ByVal bVert As Boolean) As Long
Static lDPI(1), hDc
If lDPI(0) = 0 Then
hDc = GetDC(0)
lDPI(0) = GetDeviceCaps(hDc, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(hDc, LOGPIXELSY)
hDc = ReleaseDC(0, hDc)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function