Universal Mouse Wheel Scroll event ( Applicable to Form and its Controls)

[Jaafar Tribak]

Workbook Demo

Hi all ,

After much trial an error, I have come up with this generic mouse wheel scroll event :

Public Sub OnScrollEvent(ByVal Obj As Object, ByVal WheelRotation As WHEEL_ROTATION, _
ByVal CtrlKey As CTRL_KEY_PRESS_STATE, ByVal X As Long, ByVal Y As Long)

​

Where:

Obj: holds the Control located under the mouse pointer when wheel-mouse scrolling (or holds the form if no control is under the mouse pointer)
WheelRotation: Backward or Forward
CtrlKey: holds the Ctrl key press state when mouse-wheel scrolling - either Up or Down (When the Ctrl key is held down, the scrolling is performed horizontally)
X,Y: hold the mouse pointer screen coordinates in pixels

To make it work, just set the EnableWheelScroll Property to True in the form activate event such as:

Private Sub UserForm_Activate()
Me.EnableWheelScroll = True
End Sub
​

​

Limitations:
-Works withh all controls except for MultiPages
-Doesn't work with Modeless userforms

Caveats:
-Any unhandled compile and/or runtime errors while the wheel scrolling is enabled will crash excel ! .. so the users/developpers must be vigilant and must properly debug any code that they might want to add

1- Code in a Standard module:

Option Explicit

Public Enum CTRL_KEY_PRESS_STATE
    Released
    Pressed
End Enum
Public Enum WHEEL_ROTATION
    Forward
    BackWard
End Enum

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 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 GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function AccessibleChildren Lib "oleacc.dll" (ByVal paccContainer As IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Variant, ByRef pcObtained As Long) As Long
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef psa() As Any) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SetActiveWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long

Private Const WH_CBT = 5
Private Const HCBT_CREATEWND = 3
Private Const HCBT_DESTROYWND = 4
Private Const WM_MOUSEWHEEL = &H20A
Private Const GWL_WNDPROC = -4
Private Const WM_LBUTTONDOWN = &H201
Private Const GW_CHILD = 5
Private Const FIRST_CHILD = 0&
Private Const SM_CXVSCROLL = 2
Private Const SM_CYHSCROLL = 3
Private Const SM_CXHTHUMB = 10

Private objRibbonTab As IAccessible
Private oAcc As IAccessible
Private Ctls() As Object
Private XY() As Variant
Private CtrlsCounter As Long
Private lFormClientHwnd As Long

Private hwndCombo As Long
Private lHook As Long
Private lPrevWndProc As Long
Private lFormHwnd As Long
Private oScrollableObject As Object
Private CurrentCombo As Control


Public Sub SetScrollHook(ByVal ScrollableObject As Object, ByVal Enable As Boolean)
    If Enable Then
        Set oScrollableObject = ScrollableObject
        lFormHwnd = FindWindow(vbNullString, ScrollableObject.Caption)
        lFormClientHwnd = GetWindow(lFormHwnd, GW_CHILD)
        lPrevWndProc = SetWindowLong(lFormHwnd, GWL_WNDPROC, AddressOf WindowProc)
        lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
        Call StoreCurrentControlsLocation
    Else
        UnhookWindowsHookEx lHook
        Call SetWindowLong(lFormHwnd, GWL_WNDPROC, lPrevWndProc)
    End If
End Sub


    
Private Function GetAccessible(ByRef probjElement As IAccessible, ByRef oCtls() As Object, ByRef XY() As Variant, ByRef Counter As Long) As IAccessible
    Dim avntChildrenArray() As Variant
    Dim objChild As IAccessible, objReturnElement As IAccessible
    Dim ialngChild As Long
    Dim X As Long, Y As Long, W As Long, H As Long
    avntChildrenArray = GetChildren(probjElement)
    If CBool(SafeArrayGetDim(avntChildrenArray)) Then
        For ialngChild = LBound(avntChildrenArray) To UBound(avntChildrenArray)
            If TypeOf avntChildrenArray(ialngChild) Is IAccessible Then
                Set objChild = avntChildrenArray(ialngChild)
                If TypeName(probjElement) <> "Page" Then
                Call objChild.accLocation(X, Y, W, H)
            End If
            Set oCtls(Counter) = objChild
            XY(Counter) = X & "*" & Y
            Counter = Counter + 1
            Set objReturnElement = GetAccessible(objChild, oCtls, XY, Counter)
                If Not objReturnElement Is Nothing Then Exit For
            End If
        Next
    End If
    Set GetAccessible = objReturnElement
    Set objReturnElement = Nothing
    Set objChild = Nothing
End Function

Private Function GetChildren(ByRef probjElement As IAccessible) As Variant()
    Dim lngChildCount As Long, lngReturn As Long
    Dim avntChildrenArray() As Variant
    lngChildCount = probjElement.accChildCount
    If lngChildCount > 0 Then
        ReDim avntChildrenArray(lngChildCount - 1)
        Call AccessibleChildren(probjElement, FIRST_CHILD, _
        lngChildCount, avntChildrenArray(0), lngReturn)
    End If
    GetChildren = avntChildrenArray
End Function

Private Function HookProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim ret As Long, sClassName As String
    If idHook >= 0 Then
        Select Case idHook
            Case HCBT_CREATEWND
                sClassName = Space$(128)
                ret = GetClassName(wParam, ByVal sClassName, 128)
                sClassName = Left$(sClassName, ret)
                If sClassName = "F3 MdcPopup 60000000" Then
                    hwndCombo = wParam
                    Set CurrentCombo = oScrollableObject.ActiveControl
                    Application.OnTime Now, "StoreDropDownHwnd"
                End If
        End Select
    End If
    HookProc = CallNextHookEx(lHook, idHook, wParam, ByVal lParam)
End Function

Private Sub StoreDropDownHwnd()
 hwndCombo = GetWindow(hwndCombo, GW_CHILD)
End Sub

Private Sub StoreCurrentControlsLocation()
    CtrlsCounter = 0
    ReDim Ctls(oScrollableObject.Controls.Count + 2)
    ReDim XY(oScrollableObject.Controls.Count + 2)
    Set oAcc = oScrollableObject
    Set objRibbonTab = GetAccessible(oAcc, Ctls, XY, CtrlsCounter)
End Sub

Private Function WindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim CtrlKey  As CTRL_KEY_PRESS_STATE
    Dim WheelRotation As WHEEL_ROTATION
    Dim vKid As Variant
    Dim tpt As POINTAPI
    Dim X As Long, Y As Long, W As Long, H As Long
    Dim LoWord As Long, HIWORD As Long
    Dim Res As Long
    Dim tRect As RECT
    
    On Error Resume Next
    If IsWindowVisible(hwndCombo) = 0 Then
        SetActiveWindow hwnd
    End If
    Select Case Msg
        Case WM_MOUSEWHEEL
        Call StoreCurrentControlsLocation
            LoWord = wParam And &HFFFF&
            HIWORD = wParam \ &H10000 And &HFFFF&
            WheelRotation = IIf(HIWORD = 120, Forward, BackWard)
            CtrlKey = IIf(LoWord = 8, Pressed, Released)
            GetCursorPos tpt
            AccessibleObjectFromPoint tpt.X, tpt.Y, oAcc, vKid
            If IsWindow(hwndCombo) And WindowFromPoint(tpt.X, tpt.Y) = hwndCombo Then
                GetWindowRect hwndCombo, tRect
                Call oScrollableObject.OnScrollEvent(CurrentCombo, WheelRotation, CtrlKey, tpt.X, tpt.Y)
                If CtrlKey = Pressed Then
                    If WheelRotation = BackWard Then
                        tpt.X = tRect.Right - (GetSystemMetrics(SM_CXVSCROLL) + GetSystemMetrics(SM_CXHTHUMB) / 2)
                        tpt.Y = tRect.Bottom - (GetSystemMetrics(SM_CYHSCROLL) / 2)
                    Else
                        tpt.X = tRect.Left + (GetSystemMetrics(SM_CXVSCROLL) / 2)
                        tpt.Y = tRect.Bottom - (GetSystemMetrics(SM_CYHSCROLL) / 2)
                    End If
                     ScreenToClient hwndCombo, tpt
                    Call PostMessage(hwndCombo, WM_LBUTTONDOWN, &H1, MakelParam(tpt.X, tpt.Y))
                   
                End If
                 Exit Function
            End If
            Call oAcc.accLocation(X, Y, W, H, 0&)
            Res = WorksheetFunction.Match(X & "*" & Y, XY(), 0)
            If Err = 0 Then
                Call oScrollableObject.OnScrollEvent(Ctls(Res - 1), WheelRotation, CtrlKey, tpt.X, tpt.Y)
            ElseIf WindowFromPoint(tpt.X, tpt.Y) = lFormClientHwnd Then
                Call oScrollableObject.OnScrollEvent(oScrollableObject, WheelRotation, CtrlKey, tpt.X, tpt.Y)
            End If
    End Select
    WindowProc = CallWindowProc(lPrevWndProc, lFormHwnd, Msg, wParam, lParam)
    Exit Function
End Function

Public Function MakelParam(ByVal Low As Long, ByVal High As Long) As Long
        MakelParam = LoWord(Low) Or (&H10000 * LoWord(High))
End Function

Public Function LoWord(ByVal Word As Long) As Long
        If Word And &H8000& Then
            LoWord = Word Or &HFFFF0000
        Else
            LoWord = Word And &HFFFF&
        End If
End Function

2- Code in the UserForm module

Option Explicit

[B][COLOR=#008000]'***************************************************************************************************
'WARNING!!! : Any unhandled compile/runtime errors while the WheelScroll is Enabled will crash Excel
'===========
'***************************************************************************************************[/COLOR][/B]
Private Sub UserForm_Activate()
  Me.EnableWheelScroll = True
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Me.EnableWheelScroll = False
End Sub

Public Property Let EnableWheelScroll(ByVal Enable As Boolean)
    Call SetScrollHook(Me, Enable)
End Property

[COLOR=#008000][B]'Example based on the userform1 controls/layout .. change as required[/B][/COLOR]
Public Sub OnScrollEvent(ByVal Obj As Object, ByVal WheelRotation As WHEEL_ROTATION, _
ByVal CtrlKey As CTRL_KEY_PRESS_STATE, ByVal X As Long, ByVal Y As Long)

    Select Case True
    
        Case TypeName(Obj) = Me.Name Or TypeName(Obj) = "Frame"
            If WheelRotation = BackWard Then
                If CtrlKey = Released Then
                    Obj.Scroll , fmScrollActionLineDown
                Else
                    Obj.Scroll fmScrollActionLineDown
                End If
            End If
            If WheelRotation = Forward Then
                If CtrlKey = Released Then
                    Obj.Scroll , fmScrollActionLineUp
                Else
                    Obj.Scroll fmScrollActionLineUp
                End If
            End If
        Case Obj Is SpinButton1
                If WheelRotation = BackWard Then
                    TextBox1 = Obj.value - 1
                Else
                     TextBox1 = Obj.value + 1
                End If
                Obj.value = TextBox1
                
        Case Obj Is TextBox2
            With Obj
                If Not ActiveControl Is Obj Then
                    .SetFocus
                    .SelStart = 0
                End If
                .SelStart = IIf(.SelStart = .LineCount, 0, .SelStart)
                If WheelRotation = BackWard Then
                    .CurLine = IIf(.CurLine = .LineCount - 1, .CurLine, .CurLine + 1)
                Else
                    .CurLine = .CurLine - 1
                End If
            End With
    
        Case TypeName(Obj) = "ListBox"
            Obj.SetFocus
            If Obj.ListCount > 0 And Obj.TopIndex <> -1 Then
                If WheelRotation = BackWard Then
                    If CtrlKey = Released Then
                        Obj.TopIndex = Obj.TopIndex + 1
                    Else
                        SendKeys "{RIGHT}", True
                    End If
                End If
                If WheelRotation = Forward Then
                    If CtrlKey = Released Then
                        Obj.TopIndex = Obj.TopIndex - 1
                    Else
                        SendKeys "{LEFT}", True
                    End If
                End If
             End If
    
          Case TypeName(Obj) = "ComboBox"
            If Obj.ListCount > 0 And Obj.TopIndex <> -1 Then
                If WheelRotation = BackWard Then
                    If CtrlKey = Released Then
                        Obj.TopIndex = Obj.TopIndex + 1
                    End If
                End If
                If WheelRotation = Forward Then
                    If CtrlKey = Released Then
                        Obj.TopIndex = Obj.TopIndex - 1
                    End If
                End If
             End If
    
         Case Obj Is ScrollBar1
            If WheelRotation = BackWard Then
                If Obj.value < Obj.Max Then
                    Obj.value = Obj.value + 1
                End If
            End If
            If WheelRotation = Forward Then
                If Obj.value > Obj.Min Then
                    Obj.value = Obj.value - 1
                End If
            End If
    
         Case Obj Is ScrollBar2
            If CtrlKey = Pressed Then
                If WheelRotation = BackWard Then
                    If Obj.value < Obj.Max Then
                        Obj.value = Obj.value + 1
                    End If
                End If
                If WheelRotation = Forward Then
                    If Obj.value > Obj.Min Then
                        Obj.value = Obj.value - 1
                    End If
                End If
            End If
            
    End Select
    
    lblScrObj.Caption = Obj.Name: lblWheelRot = IIf(WheelRotation = BackWard, "Backward", "Forward")
    lblCtrlK = IIf(CtrlKey = Released, "Released", "Pressed"): lblX = X: lblY = Y
End Sub