ComboBox Scroll with Mouse wheel

D

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:
Sort by date Sort by votes
Hi



I have tested the code, now also on my desktop it works without any problems. :)

Thank you very much, it's the best gift for me on my birthday (y)
 
Last edited:
Upvote 0

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
ISY said:
Hi

I have tested the code, now also on my desktop it works without any problems. :)
Thank you very much, it's the best gift for me on my birthday (y)
Click to expand...

Glad it works and thank you for the feedback.

Next, let's see if we can make the same work for ActiveX Listboxes embedeed on worksheets.

Enabling mouse scrolling for listboxes is more difficult as the mouse scrolling functionality is supposed to be enabled without the need to select the listbox control first - ie: just by hovering the mouse pointer over the listbox.

Regards.
 
Upvote 0
Hi @Jaafar Tribak and THANK YOU SO MUCH,

your Code is extremely good and and I never thought it would be possible. I've got one stupid question, sorry:

Is it possible to change the code so that the scroll amount is more than 1? I changed some figures which I supposed to be responsible but it only worked with upscrolling.
I would like, e.g. to scroll 10 lines with one spin of the mousewheel.
 
Upvote 0
Monk_c_ said:
Is it possible to change the code so that the scroll amount is more than 1? I changed some figures which I supposed to be responsible but it only worked with upscrolling.
I would like, e.g. to scroll 10 lines with one spin of the mousewheel.
Click to expand...

Just define a module level Const to set the number of lines per scroll and post WM_LBUTTONDOWN\WM_LBUTTONDOWN that number of times

I have updated the workbook example


Changes in red :

Rich (BB code): 
Option Explicit

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

Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type

#If  VBA7 Then
    #If  Win64 Then
        Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    #Else
        Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If
    Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As LongPtr
    Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    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 hHook As LongPtr) 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 GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Dim hwnd As LongPtr, lMouseHook As LongPtr
#Else
    Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function GetActiveWindow Lib "user32" () As Long
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
    Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) 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 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 GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Dim hwnd As Long, lMouseHook As Long
#End  If

Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Const HC_ACTION = 0
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Const MK_LBUTTON = &H1
Const SM_CXVSCROLL = 2
Const LINES_PER_SCROLL = 10



Public Property Let EnableMouseScroll(ByVal ComboBox As Object, ByVal Enable As Boolean)

    Dim tpt As POINTAPI, sBuffer As String * 256, lRet As Long  
  
    Application.EnableCancelKey = xlDisabled
    On Error GoTo XitProp
  
    If Enable Then
        If lMouseHook = 0 Then
            GetCursorPos tpt
            #If  VBA7 And Win64 Then
                Dim lPt As LongPtr
                CopyMemory lPt, tpt, LenB(tpt)
                hwnd = WindowFromPoint(lPt)
            #Else
                hwnd = WindowFromPoint(tpt.x, tpt.y)
            #End  If
            lRet = GetClassName(GetParent(hwnd), sBuffer, 256)
            If InStr(Left(sBuffer, lRet), "MdcPopup") Then
                Debug.Print "Mousecroll Enabled for : " & ComboBox.Name
                SetFocus hwnd
                #If  VBA7 Then
                    lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.HinstancePtr, 0)
                #Else
                    lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.Hinstance, 0)
                #End  If
                Do While IsWindow(hwnd)
                    DoEvents
                Loop
                GoTo XitProp
            End If
        End If
    Else
        If lMouseHook Then
            GoTo XitProp
        End If
    End If
    Exit Property
  
XitProp:
  
    UnhookWindowsHookEx lMouseHook: lMouseHook = 0
    Debug.Print "Mousecroll Disabled for : " & ComboBox.Name

End Property



#If  VBA7 Then
    Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, lParam As MSLLHOOKSTRUCT) As LongPtr
#Else
    Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
#End  If
      
    Dim tRect As RECT
    Dim Low As Integer, High As Integer, i As Integer
  
    On Error GoTo errHandler
  
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            #If  VBA7 And Win64 Then
                Dim lPt As LongPtr
                Dim lParm As LongPtr
                CopyMemory lPt, lParam.pt, LenB(lPt)
                If WindowFromPoint(lPt) = hwnd Then
            #Else
                Dim lParm As Long
                If WindowFromPoint(lParam.pt.x, lParam.pt.y) = hwnd Then
            #End  If
                    GetClientRect hwnd, tRect
                    If lParam.mouseData > 0 Then
                        Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
                        High = tRect.Top + ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
                    Else
                        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
                        PostMessage hwnd, WM_LBUTTONDOWN, MK_LBUTTON, lParm
                        PostMessage hwnd, WM_LBUTTONUP, MK_LBUTTON, lParm
                    Next i
                End If
        End If
    End If

    MouseProc = CallNextHookEx(lMouseHook, nCode, wParam, ByVal lParam)
    Exit Function
  
errHandler:
   
     UnhookWindowsHookEx lMouseHook: lMouseHook = 0
  
End Function


Private Function MakeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long
    MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
End Function
 
Last edited by a moderator:
Upvote 0
Jaafar Tribak said:
Just define a module level Const to set the number of lines per scroll and post WM_LBUTTONDOWN\WM_LBUTTONDOWN that number of times

I have updated the workbook example


Changes in red :

Code: 
Option Explicit

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

Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
        Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
        Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As LongPtr
    Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    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 hHook As LongPtr) 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 GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Dim hwnd As LongPtr, lMouseHook As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
    Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function GetActiveWindow Lib "user32" () As Long
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
    Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) 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 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 GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Dim hwnd As Long, lMouseHook As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Const HC_ACTION = 0
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Const MK_LBUTTON = &H1
Const SM_CXVSCROLL = 2
[COLOR=#ff0000][B]Const LINES_PER_SCROLL = 10
[/B][/COLOR]


Public Property Let EnableMouseScroll(ByVal ComboBox As Object, ByVal Enable As Boolean)

    Dim tpt As POINTAPI, sBuffer As String * 256, lRet As Long   
   
    Application.EnableCancelKey = xlDisabled
    On Error GoTo XitProp
   
    If Enable Then
        If lMouseHook = 0 Then
            GetCursorPos tpt
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 And Win64 Then
                Dim lPt As LongPtr
                CopyMemory lPt, tpt, LenB(tpt)
                hwnd = WindowFromPoint(lPt)
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
                hwnd = WindowFromPoint(tpt.x, tpt.y)
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
            lRet = GetClassName(GetParent(hwnd), sBuffer, 256)
            If InStr(Left(sBuffer, lRet), "MdcPopup") Then
                Debug.Print "Mousecroll Enabled for : " & ComboBox.Name
                SetFocus hwnd
                [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
                    lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.HinstancePtr, 0)
                [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
                    lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.Hinstance, 0)
                [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
                Do While IsWindow(hwnd)
                    DoEvents
                Loop
                GoTo XitProp
            End If
        End If
    Else
        If lMouseHook Then
            GoTo XitProp
        End If
    End If
    Exit Property
   
XitProp:
   
    UnhookWindowsHookEx lMouseHook: lMouseHook = 0
    Debug.Print "Mousecroll Disabled for : " & ComboBox.Name

End Property



[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, lParam As MSLLHOOKSTRUCT) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
    Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
       
    Dim tRect As RECT
    Dim Low As Integer, High As Integer, i As Integer
   
    On Error GoTo errHandler
   
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 And Win64 Then
                Dim lPt As LongPtr
                Dim lParm As LongPtr
                CopyMemory lPt, lParam.pt, LenB(lPt)
                If WindowFromPoint(lPt) = hwnd Then
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
                Dim lParm As Long
                If WindowFromPoint(lParam.pt.x, lParam.pt.y) = hwnd Then
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
                    GetClientRect hwnd, tRect
                    If lParam.mouseData > 0 Then
                        Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
                        High = tRect.Top + ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
                    Else
                        Low = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) / 2)
                        High = tRect.Bottom - ((GetSystemMetrics(SM_CXVSCROLL) / 2) + 1)
                    End If
                    lParm = MakeDWord(Low, High)
                    [B][COLOR=#ff0000]For i = 1 To LINES_PER_SCROLL[/COLOR][/B]
                        [COLOR=#ff0000][B]PostMessage hwnd, WM_LBUTTONDOWN, MK_LBUTTON, lParm[/B][/COLOR]
                        [COLOR=#ff0000][B]PostMessage hwnd, WM_LBUTTONUP, MK_LBUTTON, lParm[/B][/COLOR]
                    [COLOR=#ff0000][B]Next i[/B][/COLOR]
                End If
        End If
    End If

    MouseProc = CallNextHookEx(lMouseHook, nCode, wParam, ByVal lParam)
    Exit Function
   
errHandler:
    
     UnhookWindowsHookEx lMouseHook: lMouseHook = 0
   
End Function


Private Function MakeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long
    MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
End Function
Click to expand...



Jaafar, this is gold!
It works great on Userform and Sheet Comboboxes. I just wasn't able to make it work in a Listbox.
Is there any way to modify the code to include Listboxes?
Thank you!
 
Upvote 0
dma431 said:
Jaafar, this is gold!
It works great on Userform and Sheet Comboboxes. I just wasn't able to make it work in a Listbox.
Is there any way to modify the code to include Listboxes?
Thank you!
Click to expand...

Hi dma431,

A listbox will be difficult if on a sheet. .. If on a userform, I guess it could be done.
I'll take a look at some point when I have time.

Regards.
 
Upvote 0
Yes, I needed it for a userform listbox.
Thanks for looking into it. Whenever you have time, of course.
 
Upvote 0
dma431

Here is the code for mousewheel-srolling userform ListBoxes.

This code is much safer than the one for worksheet listboxes in post#34 because it doesn't use a low-level windows hook . This code uses the PeekMeessage alternative. That way, if an unhandled error occurs, the application won't crash.

Workbook Demo.


1- Code in a Standard Module:
VBA Code: 
Option Explicit

' Jaafar Tribak @ MrExcel.com on 28/01/20
' Code that enables the mousewheel in vba Userform listboxes.

' USAGE:
' ------
'  Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
'      EnableMouseScroll(ListBox1) = 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
    #Else
       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

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

#End If

' API consts
Private Const WM_MOUSEWHEEL = &H20A
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
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 ListBox As Object, ByVal Enable As Boolean)

    #If VBA7 Then
        Dim hwnd As LongPtr
    #Else
        Dim hwnd As Long
    #End If

    Dim tRect As RECT, tCurPos As POINTAPI, tMsg As MSG
    Dim Low As Integer, High As Integer, i As Integer


    ListBox.SetFocus
    WindowFromAccessibleObject ListBox, hwnd
 
    If Not bMonitoringMouseWheel Then
        bMonitoringMouseWheel = True
        If Enable Then
            Call UserFeedBack("Monitoring MouseWheel Messages for : (" & ListBox.Name & ")")
            Do While IsWindow(hwnd)
                GetCursorPos tCurPos
                If IsMouseOverListBox(ListBox, tCurPos) = False Then
                    Exit Do
                End If
                WaitMessage
                If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE) Then
                    GetClientRect tMsg.hwnd, tRect
                    #If Win64 Then
                        Dim lParm As LongPtr
                        If IsMouseOverListBox(ListBox, tMsg.pt) Then
                            If tMsg.wParam Mod 120 = 0 Then
                    #Else
                        Dim lParm As Long
                        If IsMouseOverListBox(ListBox, tMsg.pt) Then
                            If tMsg.wParam > 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
                            lParm = MakeDWord(Low, High)
                            For i = 1 To LINES_PER_SCROLL '<=== (LINES_PER_SCROLL):Change this scroll lines Const as required
                                PostMessage hwnd, WM_LBUTTONDOWN, MK_LBUTTON, lParm
                                PostMessage hwnd, 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(ByVal ListBox As Object, ByRef CusPos As POINTAPI) As Boolean

    #If VBA7 Then
        Dim hwnd As LongPtr
    #Else
        Dim hwnd As Long
    #End If
 
    WindowFromAccessibleObject ListBox, hwnd
    #If Win64 Then
        Dim lPt As LongPtr
        CopyMemory lPt, CusPos, LenB(lPt)
        If WindowFromPoint(lPt) = hwnd Then
    #Else
        If WindowFromPoint(CusPos.x, CusPos.y) = hwnd Then
    #End If
            IsMouseOverListBox = True
    End If

End Function

Private Function MakeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long
    MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
End Function

Private Sub UserFeedBack(ByVal Feedback As String)
    Debug.Print Feedback
    sFeedback = Feedback
End Sub



USAGE:
2- Code in the UserForm Module ( Tested on two ListBoxes)
VBA Code: 
Option Explicit

Private Sub UserForm_Initialize()

    Dim i As Long
 
    For i = 1 To 1000
        Me.ListBox1.AddItem i
        Me.ListBox2.AddItem Chr(WorksheetFunction.RandBetween(32, 126))
    Next i

End Sub


Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)

    EnableMouseScroll(ListBox1) = True
 
    ' Optional user-feedback
    lblFeedBack.Caption = sFeedback
 
End Sub


Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)

    EnableMouseScroll(ListBox2) = True
 
    ' Optional user-feedback
    lblFeedBack.Caption = sFeedback
 
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
276
huiettcm
H
A
  • Question
What is wrong with this VBA code: userForm get hand ico for pointer on hover
2
Replies
15
Views
499
RoryA
RoryA
D
  • Question
MouseScroll in UserForm ComboBox/ListBox
Replies
0
Views
2K
d365b
D
Jaafar Tribak
  • Question
Blurring images using Direct2D & Windows Imaging Component
Replies
3
Views
237
Dan_W
D
netspeedz
  • Solved
Load Image in User Form - 64bit Excel [VBA]
Replies
6
Views
347
netspeedz
netspeedz

Forum statistics

Threads
1,214,632
Messages
6,120,649
Members
448,975
Latest member
sweeberry

Share this page

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