Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
Hi all,
This is a continuation of this MrExcel thread which grew to the point where it became confusing and difficult to follow with so many small updates and improvements.
So I am starting here a fresh clean thread with (hopefully) a final update which has been revised and tested on 32bit & 64bit platforms by myself and by a couple of fellow members .
I will be linking this thread in the original one as well.
Workbook demo.
1- API code in a Standard Module:
2- Usage example for worksheet embeeded ListBoxes&ComboBoxes : (goes in the worksheet module)
3- Usage example for ListBoxes&ComboBoxes on UserForms : (goes in the UserForm module)
This is a continuation of this MrExcel thread which grew to the point where it became confusing and difficult to follow with so many small updates and improvements.
So I am starting here a fresh clean thread with (hopefully) a final update which has been revised and tested on 32bit & 64bit platforms by myself and by a couple of fellow members .
I will be linking this thread in the original one as well.
Workbook demo.
1- API code in a Standard Module:
VBA Code:
Option Explicit
' Jaafar Tribak @ MrExcel.com on 22/04/20 (last update on 05/10/2020)
' Generic code that enables mousewheel scrolling in vba ListBoxes & ComboBoxes
' in worksheests and Userforms .
'Property.
'EnableMouseWheelScroll (Write Boolean )
'Args :1- ListOrComboControl As Object
' 2- Optional WheelScrollLines As Long =1
' 3- Optional ChangeControlValueAsYouScroll As Boolean = False
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type MSG
#If Win64 Then
hwnd As LongLong
message As Long
wParam As LongLong
lParam As LongLong
#Else
hwnd As Long
message As Long
wParam As Long
lParam As Long
#End If
time As Long
pt As POINTAPI
End Type
#If VBA7 Then
#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
Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetQueueStatus Lib "user32" (ByVal fuFlags As Long) As Long
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
#Else
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
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetQueueStatus Lib "user32" (ByVal fuFlags As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
#End If
Public sUserFeedBack As String
Private bMonitoringMouseWheel As Boolean
Private bSomeKeyIsBeingPressed As Boolean
Public Property Let EnableMouseWheelScroll _
( _
ByVal ListOrComboControl As Object, _
Optional ByVal WheelScrollLines As Long = 1, _
Optional ByVal ChangeControlValueAsYouScroll As Boolean, _
ByVal Enable As Boolean _
)
Const WM_MOUSEWHEEL = &H20A
Const WHEEL_DELTA = 120
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Const MK_LBUTTON = &H1
Const WM_KEYDOWN = &H100
Const WM_KEYUP = &H101
Const VK_ESCAPE = &H1B
Const PM_NOREMOVE = &H0
Const PM_NOYIELD = &H2
Const QS_KEY = &H1
Const SM_CXVSCROLL = 2
#If VBA7 Then
Static hActualList As LongPtr
Dim hwnd As LongPtr
#Else
Static hActualList 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
Call WindowFromAccessibleObject(ListOrComboControl, hwnd)
If Not bMonitoringMouseWheel Then
bMonitoringMouseWheel = True
If Enable Then
Call UserFeedBack("Start Monitoring MouseWheel Messages for : (" & ListOrComboControl.Name & ")")
On Error Resume Next
Application.EnableCancelKey = xlDisabled
On Error GoTo 0
Do While IsWindow(hwnd)
Call GetCursorPos(tCurPos)
If IsMouseOverControl(ListOrComboControl, ChangeControlValueAsYouScroll, tCurPos) = False Then
Exit Do
End If
#If Win64 Then
Dim lPt As LongLong
Call 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(ListOrComboControl.Height, False)
End If
#If Win64 Then
Dim lPt2 As LongLong
Call CopyMemory(lPt2, tCurPos, LenB(lPt2))
hActualList = WindowFromPoint(lPt2)
#Else
hActualList = WindowFromPoint(tCurPos.x, tCurPos.y)
#End If
Call WaitMessage
If PeekMessage(tMsg, 0, 0, 0, PM_NOREMOVE + PM_NOYIELD) Then
If GetQueueStatus(QS_KEY) Then
bSomeKeyIsBeingPressed = True
Else
bSomeKeyIsBeingPressed = False
End If
If tMsg.message = WM_MOUSEWHEEL Then
Call GetClientRect(hActualList, tRect)
#If Win64 Then
Dim lParm As LongLong
If IsMouseOverControl(ListOrComboControl, ChangeControlValueAsYouScroll, tMsg.pt) = True Then
If (HighWord64(tMsg.wParam) / WHEEL_DELTA) > 0 Then
#Else
Dim lParm As Long
If IsMouseOverControl(ListOrComboControl, ChangeControlValueAsYouScroll, tMsg.pt) = True Then
If (HighWord32(tMsg.wParam) / WHEEL_DELTA) > 0 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 'End If HighWord
lParm = MakeDWord(Low, High)
For i = 1 To WheelScrollLines
Call PostMessage(hActualList, WM_LBUTTONDOWN, MK_LBUTTON, lParm)
Call PostMessage(hActualList, WM_LBUTTONUP, MK_LBUTTON, lParm)
Next i
If TypeName(ListOrComboControl.Parent) = "Worksheet" Then SetFocus hActualList
End If 'End If IsMouseOverControl
End If ' End If WM_MOUSEWHEEL
End If ' End If PeekMessage
DoEvents
Loop
If TypeName(ListOrComboControl) = "ListBox" Then
Call PostMessage(GetParent(hActualList), WM_KEYDOWN, VK_ESCAPE, Build_lParam_WM_KEYDOWN(1, &H0, False, False, False))
Call PostMessage(GetParent(hActualList), WM_KEYUP, VK_ESCAPE, Build_lParam_WM_KEYUP(1, &H0, False, False))
End If
On Error Resume Next
Application.EnableCancelKey = xlInterrupt
On Error GoTo 0
bMonitoringMouseWheel = False
Call UserFeedBack("Stopped Monitoring MouseWheel Messages for : (" & ListOrComboControl.Name & ")")
End If 'End If Enable
End If 'End If bMonitoringMouseWheel
End Property
'_____________________________________Helper Private Routines_____________________________________________________
Private Function IsMouseOverControl( _
ByVal ListOrComboControl As Object, _
ByVal ChangeControlValueAsYouScroll As Boolean, _
ByRef CusPos As POINTAPI) As Boolean
Dim vChild As Variant, oIA As IAccessible
#If Win64 Then
Dim lPt As LongLong
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
If Not ListOrComboControl Is Nothing Then
If oIA.accRole(0&) <> 46 Then
If bSomeKeyIsBeingPressed = False Then
If ChangeControlValueAsYouScroll Then
ListOrComboControl.value = ListOrComboControl.List(vChild - 1)
End If
End If
End If
End If
IsMouseOverControl = oIA.accRole(0&) = 33 Or oIA.accRole(0&) = 46
End Function
Private Sub UserFeedBack(ByVal Feedback As String)
Debug.Print Feedback
sUserFeedBack = 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 LongLong) As Long
CopyMemory HighWord64, ByVal VarPtr(wParam) + 2, 4
End Function
#End If
Private Function ScreenDPI(ByVal bVert As Boolean) As Long
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
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
Const POINTSPERINCH As Long = 72
PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function
Private Function Build_lParam( _
ByVal RepeatCount As Integer, _
ByVal ScanCode As Byte, _
ByVal ContextCode As Boolean, _
ByVal ExtendedKey As Boolean, _
ByVal PreviousKeyState As Boolean, _
ByVal TransitionState As Boolean) As Long
Dim lParamBits As Long
lParamBits = RepeatCount Or (ScanCode) Or 2 ^ 16
If ExtendedKey Then lParamBits = lParamBits Or 2 ^ 24
If ContextCode Then lParamBits = lParamBits Or 2 ^ 29
If PreviousKeyState Then lParamBits = lParamBits Or 2 ^ 30
If TransitionState Then lParamBits = lParamBits Or -2 ^ 31
Build_lParam = lParamBits
End Function
Private Function Build_lParam_WM_KEYDOWN( _
ByVal RepeatCount As Integer, _
ByVal ScanCode As Byte, _
ByVal ExtendedKey As Boolean, _
ByVal ContextCode As Boolean, _
ByVal PreviousKeyState As Boolean) _
As Long
Build_lParam_WM_KEYDOWN = Build_lParam(RepeatCount, ScanCode, ExtendedKey, ContextCode, PreviousKeyState, False)
End Function
Private Function Build_lParam_WM_KEYUP( _
ByVal RepeatCount As Integer, _
ByVal ScanCode As Byte, _
ByVal ExtendedKey As Boolean, _
ByVal ContextCode As Boolean) _
As Long
Build_lParam_WM_KEYUP = Build_lParam(RepeatCount, ScanCode, ExtendedKey, ContextCode, True, True)
End Function2- Usage example for worksheet embeeded ListBoxes&ComboBoxes : (goes in the worksheet module)
VBA Code:
Option Explicit
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
EnableMouseWheelScroll(ListOrComboControl:=ComboBox1, WheelScrollLines:=1, ChangeControlValueAsYouScroll:=True) = True
On Error Resume Next
[F1] = sUserFeedBack '<== Optional
On Error GoTo 0
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
EnableMouseWheelScroll(ListOrComboControl:=ListBox1, WheelScrollLines:=10, ChangeControlValueAsYouScroll:=False) = True
On Error Resume Next
[F1] = sUserFeedBack '<== Optional
On Error GoTo 0
End Sub3- Usage example for ListBoxes&ComboBoxes on UserForms : (goes in the UserForm module)
VBA Code:
Option Explicit
Private Sub UserForm_Initialize()
Me.ComboBox1.ListIndex = 10
Me.ComboBox2.ListIndex = 2
End Sub
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
'Change the combobox value when scrolling by setting the second Optional arg to TRUE.
EnableMouseWheelScroll(ListOrComboControl:=ComboBox1, WheelScrollLines:=1, ChangeControlValueAsYouScroll:=True) = True
lblFeedBack.Caption = sUserFeedBack '<= Optional
End Sub
Private Sub ComboBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
EnableMouseWheelScroll(ListOrComboControl:=ComboBox2, WheelScrollLines:=1, ChangeControlValueAsYouScroll:=False) = True
lblFeedBack.Caption = sUserFeedBack '<= Optional
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
EnableMouseWheelScroll(ListOrComboControl:=ListBox1, WheelScrollLines:=1, ChangeControlValueAsYouScroll:=False) = True
lblFeedBack.Caption = sUserFeedBack '<= Optional
End Sub
