ComboBox Scroll with Mouse wheel

DarkGlobus1OO

New Member
Joined
Sep 28, 2017
Messages
11
i tried to work with peter Peter Thornton (Excel MVP 2008-13) code which works amazing for userform Comboxes and listboxes but im a vba noobie and i cant seem to understand how to make this code work for a regular ComboBox on a worksheet

Module Code:
Code:
'Enables mouse wheel scrolling in controls
Option Explicit


#If Win64 Then
    Private Type POINTAPI
       XY As LongLong
    End Type
#Else
    Private Type POINTAPI
           X As Long
           Y As Long
    End Type
#End If


Private Type MOUSEHOOKSTRUCT
    Pt As POINTAPI
    hWnd As Long
    wHitTestCode As Long
    dwExtraInfo As Long
End Type


#If  VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" _
                                            Alias "FindWindowA" ( _
                                                            ByVal lpClassName As String, _
                                                            ByVal lpWindowName As String) As Long ' not sure if this should be LongPtr
    #If  Win64 Then
        Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
                                            Alias "GetWindowLongPtrA" ( _
                                                            ByVal hWnd As LongPtr, _
                                                            ByVal nIndex As Long) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" _
                                            Alias "GetWindowLongA" ( _
                                                            ByVal hWnd As LongPtr, _
                                                            ByVal nIndex As Long) As LongPtr
    #End  If
    Private 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
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
                                                            ByVal hHook As LongPtr, _
                                                            ByVal nCode As Long, _
                                                            ByVal wParam As LongPtr, _
                                                           lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
                                                            ByVal hHook As LongPtr) As LongPtr ' MAYBE Long
    'Private Declare PtrSafe Function PostMessage Lib "user32.dll" _
    '                                         Alias "PostMessageA" ( _
    '                                                         ByVal hwnd As LongPtr, _
    '                                                         ByVal wMsg As Long, _
    '                                                         ByVal wParam As LongPtr, _
    '                                                         ByVal lParam As LongPtr) As LongPtr   ' MAYBE Long
    #If  Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                            ByVal Point As LongLong) As LongPtr    '
    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
                                                            ByVal xPoint As Long, _
                                                            ByVal yPoint As Long) As LongPtr    '
    #End  If
    Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
                                                            ByRef lpPoint As POINTAPI) As LongPtr   'MAYBE Long
#Else
    Private Declare Function FindWindow Lib "user32" _
                                            Alias "FindWindowA" ( _
                                                            ByVal lpClassName As String, _
                                                            ByVal lpWindowName As String) As Long
    Private Declare Function GetWindowLong Lib "user32.dll" _
                                            Alias "GetWindowLongA" ( _
                                                            ByVal hWnd As Long, _
                                                            ByVal nIndex As Long) As Long
    Private 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
    Private Declare Function CallNextHookEx Lib "user32" ( _
                                                            ByVal hHook As Long, _
                                                            ByVal nCode As Long, _
                                                            ByVal wParam As Long, _
                                                           lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
                                                            ByVal hHook As Long) As Long
    'Private Declare Function PostMessage Lib "user32.dll" _
    '                                         Alias "PostMessageA" ( _
    '                                                         ByVal hwnd As Long, _
    '                                                         ByVal wMsg As Long, _
    '                                                         ByVal wParam As Long, _
    '                                                         ByVal lParam As Long) As Long
    Private Declare Function WindowFromPoint Lib "user32" ( _
                                                            ByVal xPoint As Long, _
                                                            ByVal yPoint As Long) As Long
    Private Declare Function GetCursorPos Lib "user32.dll" ( _
                                                            ByRef lpPoint As POINTAPI) As Long
#End  If


Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
'Private Const WM_KEYDOWN As Long = &H100
'Private Const WM_KEYUP As Long = &H101
'Private Const VK_UP As Long = &H26
'Private Const VK_DOWN As Long = &H28
'Private Const WM_LBUTTONDOWN As Long = &H201
Dim n As Long
Private mCtl As Object
Private mbHook As Boolean
#If  VBA7 Then
    Private mLngMouseHook As LongPtr
    Private mListBoxHwnd As LongPtr
#Else
    Private mLngMouseHook As Long
    Private mListBoxHwnd As Long
#End  If
     
Sub HookListBoxScroll(frm As Object, ctl As Object)
    Dim tPT As POINTAPI
    #If VBA7 Then
        Dim lngAppInst As LongPtr
        Dim hwndUnderCursor As LongPtr
    #Else
        Dim lngAppInst As Long
        Dim hwndUnderCursor As Long
    #End  If
    GetCursorPos tPT
    #If  Win64 Then
        hwndUnderCursor = WindowFromPoint(tPT.XY)
    #Else
        hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
    #End  If
    If TypeOf ctl Is UserForm Then
        If Not frm Is ctl Then
               ctl.SetFocus
        End If
    Else
        If Not frm.ActiveControl Is ctl Then
             ctl.SetFocus
        End If
    End If
    If mListBoxHwnd <> hwndUnderCursor Then
        UnhookListBoxScroll
        Set mCtl = ctl
        mListBoxHwnd = hwndUnderCursor
        #If  Win64 Then
            lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
        #Else
            lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
        #End  If
        ' PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
        If Not mbHook Then
            mLngMouseHook = SetWindowsHookEx( _
                                            WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
            mbHook = mLngMouseHook <> 0
        End If
    End If
End Sub


Sub UnhookListBoxScroll()
    If mbHook Then
        Set mCtl = Nothing
        UnhookWindowsHookEx mLngMouseHook
        mLngMouseHook = 0
        mListBoxHwnd = 0
        mbHook = False
    End If
End Sub
#If  VBA7 Then
    Private Function MouseProc( _
                            ByVal nCode As Long, ByVal wParam As Long, _
                            ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
        Dim idx As Long
        On Error GoTo errH
        If (nCode = HC_ACTION) Then
            #If  Win64 Then
                If WindowFromPoint(lParam.Pt.XY) = mListBoxHwnd Then
                    If wParam = WM_MOUSEWHEEL Then
                        MouseProc = True
'                        If lParam.hWnd > 0 Then
'                            postMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
'                        Else
'                            postMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
'                        End If
'                        postMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
                        If TypeOf mCtl Is Frame Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        ElseIf TypeOf mCtl Is UserForm Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        Else
                             If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                             idx = idx + mCtl.ListIndex
                             If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                        End If
                    Exit Function
                    End If
                Else
                    UnhookListBoxScroll
                End If
            #Else
                If WindowFromPoint(lParam.Pt.X, lParam.Pt.Y) = mListBoxHwnd Then
                    If wParam = WM_MOUSEWHEEL Then
                        MouseProc = True
'                        If lParam.hWnd > 0 Then
'                            postMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
'                        Else
'                            postMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
'                        End If
'                        postMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
                        If TypeOf mCtl Is Frame Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        ElseIf TypeOf mCtl Is UserForm Then
                            If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                            idx = idx + mCtl.ScrollTop
                            If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                                mCtl.ScrollTop = idx
                            End If
                        Else
                             If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                             idx = idx + mCtl.ListIndex
                             If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                        End If
                        Exit Function
                    End If
                Else
                    UnhookListBoxScroll
                End If
            #End If
        End If
        MouseProc = CallNextHookEx( _
                                mLngMouseHook, nCode, wParam, ByVal lParam)
        Exit Function
errH:
        UnhookListBoxScroll
    End Function
#Else
    Private Function MouseProc( _
                            ByVal nCode As Long, ByVal wParam As Long, _
                            ByRef lParam As MOUSEHOOKSTRUCT) As Long
        Dim idx As Long
        On Error GoTo errH
        If (nCode = HC_ACTION) Then
            If WindowFromPoint(lParam.Pt.X, lParam.Pt.Y) = mListBoxHwnd Then
                If wParam = WM_MOUSEWHEEL Then
                    MouseProc = True
'                    If lParam.hWnd > 0 Then
'                    postMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
'                    Else
'                    postMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
'                    End If
'                    postMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
                    
                    If TypeOf mCtl Is Frame Then
                        If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                        idx = idx + mCtl.ScrollTop
                        If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                            mCtl.ScrollTop = idx
                        End If
                    ElseIf TypeOf mCtl Is UserForm Then
                        If lParam.hWnd > 0 Then idx = -10 Else idx = 10
                        idx = idx + mCtl.ScrollTop
                        If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
                            mCtl.ScrollTop = idx
                        End If
                    Else
                         If lParam.hWnd > 0 Then idx = -1 Else idx = 1
                         idx = idx + mCtl.ListIndex
                         If idx >= 0 And idx <= mCtl.ListCount - 1 Then mCtl.ListIndex = idx
                    End If
                    Exit Function
                End If
            Else
                UnhookListBoxScroll
            End If
        End If
        MouseProc = CallNextHookEx( _
        mLngMouseHook, nCode, wParam, ByVal lParam)
        Exit Function
errH:
        UnhookListBoxScroll
    End Function
#End  If


hope someone here can help me i have been scratching my head around this problem for days!
:confused::confused::confused::confused:
 
Last edited by a moderator:
Hi @Jaafar Tribak, I really like your coding, thanks a lot!
Downloaded your demo Workbook and played around a bit but I couldn't (of course, LOL ...) fix the issue I'm having.
On 32 bit Excel 2013 running your code, regardless in which direction the mouse wheel is turned, the Userform Control scrolls always downwards. For some reason the line
If HighWord32(tMsg.wParam) = WHEEL_DELTA Then
in the EnableMouseScroll property procedure never evaluates to TRUE.
Just to let you know.
Thanks for the feedback.

I tetsed the code on 32bit excel 2013 and it worked just fine for me.

Can you add this Debug.Print statement right after the line : "If tMsg.message = WM_MOUSEWHEEL" and tell me the ouput you get when scrolling UP and DOWN ?

If tMsg.message = WM_MOUSEWHEEL Then
Debug.Print HighWord32(tMsg.wParam)
 
Upvote 0

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Thanks for looking into it. Changing the WM_MOUSEWHEEL constant seems to solve the issue, am I right?
Results from the Worksheet Controls in the order down-up, down-up:
Rich (BB code):
Start Monitoring MouseWheel Messages for : (ListBox1)
-30 
MouseWheel Scrolling (Down)
Stopped Monitoring MouseWheel Messages for : (ListBox1)
Start Monitoring MouseWheel Messages for : (ListBox1)
 30 
MouseWheel Scrolling (Down)
Stopped Monitoring MouseWheel Messages for : (ListBox1)
Start Monitoring MouseWheel Messages for : (ComboBox1)
-30 
Stopped Monitoring MouseWheel Messages for : (ComboBox1)
Start Monitoring MouseWheel Messages for : (ComboBox1)
 30 
Stopped Monitoring MouseWheel Messages for : (ComboBox1)

Results from the Userform Controls in the order down-up, down-up, down-up:
Rich (BB code):
Start Monitoring MouseWheel Messages for : (ComboBox1)
-30 
Stopped Monitoring MouseWheel Messages for : (ComboBox1)
Start Monitoring MouseWheel Messages for : (ComboBox1)
 30 
Stopped Monitoring MouseWheel Messages for : (ComboBox1)
Start Monitoring MouseWheel Messages for : (ComboBox2)
-30 
Stopped Monitoring MouseWheel Messages for : (ComboBox2)
Start Monitoring MouseWheel Messages for : (ComboBox2)
 30 
Stopped Monitoring MouseWheel Messages for : (ComboBox2)
Start Monitoring MouseWheel Messages for : (ListBox1)
-30 
MouseWheel Scrolling (Down)
Stopped Monitoring MouseWheel Messages for : (ListBox1)
Start Monitoring MouseWheel Messages for : (ListBox1)
 30 
MouseWheel Scrolling (Down)
Stopped Monitoring MouseWheel Messages for : (ListBox1)
 
Upvote 0
@GWteB

Thanks for letting me know .

I wasn't aware of this, but after some investigation I found out that, very rarely, some mouses with finer-resolution wheels may have a smaller WHEEL_DELTA.

Anyway, since the high word in the wParam always returns a positive value when scrolling up and a negative value when scrolling down, we should be able to amend the code as follows :

Replace this line:
VBA Code:
If HighWord32(tMsg.wParam) = WHEEL_DELTA Then

With this line:
VBA Code:
 If (HighWord32(tMsg.wParam) / WHEEL_DELTA) > 0 Then

Can you please test the above and let us know so I can post a final update including a couple of other small tweaks.
 
Upvote 0
This modification indeed has the desired effect (... I could have known since the outcome will (no matter what) be negative or positive and thus will always reflect the right scroll direction).
As you may have discovered yourself, with regard to both combo boxes with "change value on scroll" there is some odd behaviour. The most striking is when the mouse hoovers over the bottom or second bottom value and user scrolls upwards. Scrolling upwards is acually detected, nevertheless there is no scrolling. The combo box switches (rapidly) back and forth between third bottom value (298) and second bottom value (299). I also fiddled with that a bit without any result yet. The other combo box and both list boxes work as expected.
Nice job again (y) and while exploring your code I learn a lot. Thanks.
 
Upvote 0
As you may have discovered yourself, with regard to both combo boxes with "change value on scroll" there is some odd behaviour. The most striking is when the mouse hoovers over the bottom or second bottom value and user scrolls upwards. Scrolling upwards is acually detected, nevertheless there is no scrolling. The combo box switches (rapidly) back and forth between third bottom value (298) and second bottom value (299). I also fiddled with that a bit without any result yet. The other combo box and both list boxes work as expected.
Nice job again (y) and while exploring your code I learn a lot. Thanks.

Yes, I think I know what you mean and I noticed that subtle buggy behaviour which I have now hopefully fixed.

Also, the LINES_PER_SCROLL constant should probably not be set globally at module level. The lines per scroll value should ideally be added to the EnableMouseScroll Property as a seperate optional argument defaulting to 1 line per scroll which can be flexibly set by the user for each control individually (It is more intuitive and in keeping with good coding practice).

I will post the final update later on when I get home but in a new seperate thread (hoping I am not violating forum rules by doing so.) because this thread has become so cluttered, it is confusing and difficult to follow - I'll post here a link that directs to the new thread.

Thanks for testing and revising the code.
 
Upvote 0
Link to the new thread :
 
Upvote 0
Hello there,

I just downloaded this code and I have a few questions:
When I use the downloaded workbook everything works fine.
So I started to implement the Modules and the code of the userform into my workbook (.xlsm) and I receive a error: runtime error 91 object variable or with block variable not set
So I started digging, checking my references and my code but I didn´t found anything suspicious.
Then I started deleting my modules and my sheets until my workbook was "naked" besides the two modules for the mouse scrolling and I still got this error.

Now I have two workbooks open in the same excel: this one here and my stripped one. Guess what: the first is working fine, the other keeps annoying me with runntime error 91.
As I mentioned above: the reverences are the same now on both workbooks.

Any idea ? Thanks for help in advance.


Regards, Mick.
 
Upvote 0
Hi Mick, Unfortunately I am not enough of a vba coder to help you with actual code.

My suggestion would be to start with the *working* workbook and add in your worksheets/modules one by one until either you have it working as you want, or it breaks hopefully at a point which will point you to exactly where the issue is.
 
Upvote 0
Today I tested it on a 32bit system and what do you know ? It worked fine. WTF ??
 
Upvote 0
Hi,

I´m still fighting with this problem. Fortunately I managed to enable the mouse scroll with office365 & 64bit by changing If HighWord64(tMsg.wParam) = WHEEL_DELTA > 10 Then ...
Mousewheelup gives me a 3-5, mousewheel down gives me a 65450something.

but like I mentioned it works only your original workbook.

For further error processing, could you explain me the following lines please ?


If oIA.accRole(0&) = 46 Then (this is where the script stops with runtime error 91)


If Not ComboBox Is Nothing And ChangeComboValueWithScroll And oIA.accRole(0&) <> 46 Then (this line seems related to first one)


IsMouseOverListBox = oIA.accRole(0&) = 33 Or oIA.accRole(0&) = 46


As soon as I hove the mouse over the listbox oIA.accRole(0&) will give me a 46 (checked with debug.print oIA.accRole(0&))


Thanks for your help,

regards, Mick.
 
Upvote 0

Forum statistics

Threads
1,224,824
Messages
6,181,187
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top