MouseWheelScrolling ListBoxes & ComboBoxes (In worksheets and UserForms)

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,069
Office Version
  1. 2016
Platform
  1. 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:
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 Function




2- 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 Sub




3- 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
 

Some videos you may like

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.

avitzavi

New Member
Joined
Apr 30, 2018
Messages
13
@Jaafar Tribak -- Thank you for your continued support! I have been following your work for many years.

I downloaded the workbook example above and when I scroll DOWN in the userform, the Comboboxes and Listbox both scroll UP instead of down.

Windows 10 x64, Office 2016(/Office 365)
 

avitzavi

New Member
Joined
Apr 30, 2018
Messages
13
Jaafar, I found that when i change the line below i can get your above workbook working for me:
If (HighWord32(tMsg.wParam) / WHEEL_DELTA) > 0

when i change this back to the old line of code you used to have in post #66 in the old thread, i am able to get the listbox to scroll up and down correctly:
If (HighWord64(tMsg.wParam) = WHEEL_DELTA) Then

Is it possible that the line of code above isnt working as expected on my x64 Win10 machine?
For debugging purposes, on my machine, WHEEL_DELTA=120 and tMsg.wParam=4287102976 (when i scroll down) and 7864320 (when i scroll up)

Edit: Also i noticed to things that were weird:
1. when i had a button's Cancel property set to true, it called the button_click macro (in this case the macro was "Unload Me" so the userform would close when i moved my mouse away)
2. when i move my mouse away from the ListBox it scrolls the listbox all the way to the top (is this related to the line above somehow?)
 
Last edited:

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,069
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

@avitzavi

Sorry for not getting back to you sooner as I was busy.

Can you try ORing the IF clause as folllows and let me know what you get :

If (HighWord64(tMsg.wParam) / WHEEL_DELTA) > 0 Or (HighWord64(tMsg.wParam) = WHEEL_DELTA) Then

EDIT:

Regarding the other question, I don't experience the issues you describe.
 

avitzavi

New Member
Joined
Apr 30, 2018
Messages
13
@avitzavi

Sorry for not getting back to you sooner as I was busy.

Can you try ORing the IF clause as folllows and let me know what you get :

If (HighWord64(tMsg.wParam) / WHEEL_DELTA) > 0 Or (HighWord64(tMsg.wParam) = WHEEL_DELTA) Then

EDIT:

Regarding the other question, I don't experience the issues you describe.

No worries sir, thank you for all of the help you provide to this community! I have many projects as well and understand that you may be busy.

i was able to get it to work using that change, but the listbox scrolls slowly and choppy for me. Like one scroll every few seconds.
Also when the mouse leaves the listbox on the userform, it scrolls to the top.
 

lockarde

Board Regular
Joined
Oct 23, 2016
Messages
77
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:
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 Function




2- 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 Sub




3- 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


Thank You!!! Works flawlessly after a few tweaks to scroll value and "change value with scroll = false" (the latter made it scroll a little sluggish)
 

Watch MrExcel Video

Forum statistics

Threads
1,118,656
Messages
5,573,428
Members
412,529
Latest member
cTatch
Top