Generic MouseWheel Scroll for UserForm and for ALL its Controls !

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,779
Office Version
  1. 2016
Platform
  1. Windows
Hi all,
Below is a code for scrolling all controls in a userform with the Mouse Wheel

Should work with Modal as well as with Modeless userforms .. Tested in 32Bit and 64Bit systems .. Also, the code doesn't use a Windows hook so it should be stable and safe.

See Workbook Demo

1- Code in a Standard Module :
Code:
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 Type LongToInteger
    Low As Integer
    High As Integer
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
    
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    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 ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) 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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As LongPtr)
    Private Declare PtrSafe Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As LongPtr) As Long
#If Win64 Then
     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
#End If

#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 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 GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wCmd As Long) 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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
    Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
#End If
 
Private Const CHILDID_SELF = &H0&
Private Const S_OK As Long = &H0
Private Const POINTSPERINCH As Long = 72
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const WM_MOUSEWHEEL = &H20A
Private Const PM_REMOVE = &H1
Private bCancelProcessing As Boolean
Private Const MK_CONTROL = &H8
Private Const SCROLL_CHANGE = 10

Private arObjCaptions() As Variant
Private arObjPointers() As Variant

Public Sub HookMouseWheelScroll(ByVal UF As Object)
    Dim WheelRotation As WHEEL_ROTATION
    Dim CtrlKey As CTRL_KEY_PRESS_STATE
    Dim tMsg As MSG
    Dim tCurPos As POINTAPI
    Dim oIA As IAccessible
    Dim oObjUnderMouse As Object
    Dim oPage As Object
    Dim oCtrl As Object
    Dim vKid  As Variant
    Dim i As Long
    Dim j As Long
    Dim lResult As Long
    Dim bCancel As Boolean
    Static k As Long
    #If VBA7 Then
        Dim Ptr As LongPtr
    #Else
        Dim Ptr As Long
    #End If
    
    bCancelProcessing = False
    k = 0
    UF.Caption = UF.Caption & Chr(10)
    j = 0
    Erase arObjCaptions
    Erase arObjPointers
    For Each oCtrl In UF.Controls
        If TypeName(oCtrl) = "MultiPage" Then
            For Each oPage In oCtrl.Pages
                i = i + 1
                oPage.Caption = oPage.Caption & String(i, Chr(10))
                ReDim Preserve arObjCaptions(j)
                ReDim Preserve arObjPointers(j)
                arObjCaptions(j) = oPage.Caption & Chr(10)
                arObjPointers(j) = ObjPtr(oPage)
                j = j + 1
            Next
        End If
    Next
    Do While Not bCancelProcessing
        DoEvents
        GetCursorPos tCurPos
        #If Win64 Then
            CopyMemory Ptr, tCurPos, LenB(tCurPos)
            lResult = AccessibleObjectFromPoint(Ptr, oIA, vKid)
        #Else
            lResult = AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
        #End If
        If lResult = S_OK Then
            On Error Resume Next
            Set oObjUnderMouse = objUnderMouse(UF, oIA, tCurPos)
            If Not oObjUnderMouse Is Nothing Then
                WaitMessage
                If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
                    CtrlKey = IIf(LoWord(CLng(tMsg.wParam)) = MK_CONTROL, Pressed, Released)
                    WheelRotation = IIf(tMsg.wParam > 0, Forward, Backward)
                    Call UF.OnScrollEvent(oObjUnderMouse, WheelRotation, CtrlKey, tMsg.pt.X, tMsg.pt.Y, bCancel)
                    If Not bCancel Then
                        If TypeName(oObjUnderMouse) = "TextBox" Then
                            With oObjUnderMouse
                                .SetFocus
                                If k = 0 Then
                                    .SelStart = 0
                                Else
                                    .SelStart = IIf(.SelStart = .LineCount, 0, .SelStart)
                                End If
                                If WheelRotation = Forward Then
                                    .CurLine = .CurLine - 1
                                Else
                                    .CurLine = IIf(.CurLine = .LineCount - 1, .CurLine, .CurLine + 1)
                                End If
                            End With
                            k = k + 1
                        End If
                        If TypeName(oObjUnderMouse) = "ScrollBar" Then
                            With oObjUnderMouse
                                If WheelRotation = Forward Then
                                    .Value = IIf(.Value - oObjUnderMouse.SmallChange > .Min, .Value - oObjUnderMouse.SmallChange, .Min)
                                Else
                                    .Value = IIf(.Value + oObjUnderMouse.SmallChange < .Max, .Value + oObjUnderMouse.SmallChange, .Max)
                                End If
                            End With
                        End If
                        If TypeName(oObjUnderMouse) = "ListBox" Or TypeName(oObjUnderMouse) = "ComboBox" Then
                            With oObjUnderMouse
                                If CtrlKey = Released Then
                                    If WheelRotation = Forward Then
                                    .TopIndex = .TopIndex - 1
                                    Else
                                    .TopIndex = .TopIndex + 1
                                    End If
                                Else
                                    .SetFocus
                                    If WheelRotation = Forward Then
                                        SendKeys "{LEFT}", True
                                        DoEvents
                                        SendKeys "{RIGHT}", True
                                    Else
                                        SendKeys "{RIGHT}", True
                                        DoEvents
                                        SendKeys "{RIGHT}", True
                                    End If
                                End If
                            End With
                        End If
                        If TypeName(oObjUnderMouse) = UF.Name Or TypeName(oObjUnderMouse) = "Frame" Or TypeName(oObjUnderMouse) = "Page" Then
                            With oObjUnderMouse
                                If CtrlKey = Released Then
                                    If WheelRotation = Forward Then
                                        .ScrollTop = Application.Max(0, .ScrollTop - 5)
                                    Else
                                        .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE)
                                    End If
                                Else
                                    If WheelRotation = Forward Then
                                        .ScrollLeft = Application.Max(0, .ScrollLeft - 5)
                                    Else
                                        .ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE)
                                    End If
                                End If
                            End With
                        End If
                    End If
                    DoEvents
                End If
            End If
        End If
    Loop
End Sub

Public Sub RemoveMouseWheelHook()
    bCancelProcessing = True
End Sub

[B][COLOR=#008000]'Private Routines ..[/COLOR][/B]
[B][COLOR=#008000]'-------------------[/COLOR][/B]
Private Function objUnderMouse(ByVal UF As Object, ByVal oAcc As IAccessible, MouseLoc As POINTAPI) As Object
    #If VBA7 Then
        Dim lngPtr As LongPtr
        Dim lObjPtr As LongPtr
        Dim lCtrlPtr As LongPtr
        Dim hwndForm As LongPtr
        Dim hwndFromPoint As LongPtr
    #Else
        Dim lObjPtr As Long
        Dim lCtrlPtr As Long
        Dim hwndForm As Long
        Dim hwndFromPoint As Long
    #End If
    Dim arCtrlsPosition() As Variant
    Dim arCtrlsPointers() As Variant
    Dim tPt As POINTAPI
    Dim tRect As RECT
    Dim oObj As Object
    Dim oCtrl As Control
    Dim sBuffer As String
    Dim lCtrlLeft As Long
    Dim lCtrlTop As Long
    Dim lPos1 As Long
    Dim lPos2 As Long
    Dim lPos3 As Long
    Dim lRet As Long
    Dim i As Long

    On Error Resume Next
    hwndForm = FindWindow(vbNullString, UF.Caption)
    For Each oCtrl In UF.Controls
        ReDim Preserve arCtrlsPosition(i + 1)
        ReDim Preserve arCtrlsPointers(i + 1)
        tPt = GetRealCtrlScreenLocation(oCtrl, hwndForm, UF)
        arCtrlsPosition(i) = tPt.X & tPt.Y
        arCtrlsPointers(i) = ObjPtr(oCtrl)
        arCtrlsPosition(i + 1) = tPt.X - 2 & tPt.Y - 1
        arCtrlsPointers(i + 1) = ObjPtr(oCtrl)
        i = i + 2
    Next
    lPos1 = WorksheetFunction.Match(oAcc.accName(CHILDID_SELF) & Chr(10), arObjCaptions, 0)
    lObjPtr = WorksheetFunction.Index(arObjPointers, 1, lPos1)
    Call oAcc.accLocation(lCtrlLeft, lCtrlTop, 0, 0, CHILDID_SELF)
    lPos2 = WorksheetFunction.Match(lCtrlLeft & lCtrlTop, arCtrlsPosition, 0)
    lCtrlPtr = WorksheetFunction.Index(arCtrlsPointers, 1, lPos2)
    #If VBA7 Then
        CopyMemory lngPtr, MouseLoc, LenB(MouseLoc)
        hwndFromPoint = WindowFromPoint(lngPtr)
    #Else
        hwndFromPoint = WindowFromPoint(MouseLoc.X, MouseLoc.Y)
    #End If
    sBuffer = Space(256)
    lRet = GetClassName(GetParent(hwndFromPoint), sBuffer, 256)
    lPos3 = InStr(1, Left(sBuffer, lRet), "MdcPopup")
    Select Case True
        Case lPos3 <> 0
            Set objUnderMouse = GetActiveComboBox(UF)
            Exit Function
        Case oAcc.accName(CHILDID_SELF) = UF.Caption
            Set oObj = UF
        Case lObjPtr = 0
            If IsBadCodePtr(lCtrlPtr) = 0 Then
                CopyMemory oObj, lCtrlPtr, 4
            End If
        Case lObjPtr <> 0
            If IsBadCodePtr(lObjPtr) = 0 Then
                CopyMemory oObj, lObjPtr, 4
            End If
    End Select
    Set objUnderMouse = oObj
    If Not oObj Is Nothing Then
        ZeroMemory oObj, 4
    End If
End Function

#If VBA7 Then
    Private Function GetRealCtrlScreenLocation(ByVal Ctl As Object, ByVal hwnd As LongPtr, ByVal UF As Object) As POINTAPI
#Else
    Private Function GetRealCtrlScreenLocation(ByVal Ctl As Object, ByVal hwnd As Long, ByVal UF As Object) As POINTAPI
#End If
    Dim tRect As RECT
    Dim tTopLeft As POINTAPI
    Dim oMultiPage As Control
    Dim oTempObj As Control

    On Error Resume Next
    Set oTempObj = Ctl.Parent
    With tTopLeft
        Select Case True
             Case oTempObj Is Nothing
                .X = PTtoPX(Ctl.Left - UF.ScrollLeft * UF.Zoom / 100, False)
                .Y = PTtoPX(Ctl.Top - UF.ScrollTop * UF.Zoom / 100, True)
                ClientToScreen hwnd, tTopLeft
             Case TypeName(oTempObj) = "Frame"
                GetWindowRect oTempObj.[_GethWnd], tRect
                .X = PTtoPX(Ctl.Left - oTempObj.ScrollLeft * (oTempObj.Zoom / 100), False) + tRect.Left + 2
                .Y = PTtoPX(Ctl.Top - oTempObj.ScrollTop * (oTempObj.Zoom / 100), True) + tRect.Top + 8
            Case TypeName(oTempObj) = "Page"
                Set oMultiPage = oTempObj.Parent
                GetWindowRect GetNextWindow(oMultiPage.[_GethWnd], 5), tRect
                .X = PTtoPX(Ctl.Left - oTempObj.ScrollLeft * (oTempObj.Zoom / 100), False) + tRect.Left
                .Y = PTtoPX(Ctl.Top - oTempObj.ScrollTop * (oTempObj.Zoom / 100), True) + tRect.Top
                Set oMultiPage = Nothing
            End Select
        End With
    GetRealCtrlScreenLocation = tTopLeft
    Set oTempObj = Nothing
End Function

Private Function GetActiveComboBox(ByVal Ctl As Object) As Control
    Dim oCtl As Object
    Dim lCur As Long
    On Error Resume Next
    For Each oCtl In Ctl.Controls
        Err.Clear
        lCur = oCtl.CurX
        If Err.Number = 0 And TypeName(oCtl) = "ComboBox" Then Set GetActiveComboBox = oCtl: Exit Function
    Next
End Function

Private Function LoWord(ByVal Word As Long) As Integer
    Dim X As LongToInteger
    CopyMemory X, Word, LenB(X)
    LoWord = X.Low
End Function

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Static lDPI(1), lDC
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

2- Code in the UserForm Module:
Code:
Option Explicit

Private Sub UserForm_Activate()
    Dim i As Long
    
    [B][COLOR=#008000]'Populate the controls[/COLOR][/B]
    For i = 0 To 100
        With ListBox1
            .ColumnCount = 4
            .ColumnWidths = "100;100;100;100"
            .AddItem "COLUMN1"
            .List(i, 1) = "COLUMN2"
            .List(i, 2) = "COLUMN3"
            .List(i, 3) = "COLUMN4"
        End With
        ListBox2.AddItem i
        ComboBox1.AddItem i
        ComboBox2.AddItem i
        ComboBox3.AddItem i
        ComboBox4.AddItem i
        ComboBox5.AddItem i
        ComboBox6.AddItem i
        ComboBox7.AddItem i
        ComboBox8.AddItem i
        ComboBox9.AddItem i
    Next i
    With TextBox1
        .Text = .Text & String(300, "A")
        .Text = .Text & String(300, "I")
        .Text = .Text & String(300, "X")
    End With
    Label1.Caption = "Object :"
    Label2.Caption = "Wheel Rotation :"
    Label3.Caption = "Scroll Direction :"
    Label4.Caption = "Cursor X :"
    Label5.Caption = "Cursor Y :"
    Label6.Caption = "Scroll Cancelled :"
    
    [B][COLOR=#008000]'Hook MouseWheel Scroll of Form and of all its controls[/COLOR][/B]
    Call HookMouseWheelScroll(Me)

End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call RemoveMouseWheelHook
End Sub
Private Sub CommandButton1_Click()
    Unload Me
End Sub
[B][COLOR=#008000]
'-------------------------[/COLOR][/B]
[B][COLOR=#008000]'Public Generic event[/COLOR][/B]
[B][COLOR=#008000]'-------------------------[/COLOR][/B]

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, Cancel As Boolean)

    Dim sObjName As String, sWheelRot As String, sCtrlKey As String
    Dim sCurX As String, sCurY As String, sCancelScrol As String
    
    sObjName = "Object :  (" & Obj.Name & ")"
    sWheelRot = "Wheel Rotation :  (" & IIf(WheelRotation = Forward, "Forward", "Backward") & ")"
    sCtrlKey = "Scroll Direction :  (" & IIf(CtrlKey = Released, "Vert", "Horiz") & ")"
    sCurX = "Cursor X :  (" & X & ")"
    sCurY = "Cursor Y :  (" & Y & ")"
    sCancelScrol = "Scroll Cancelled :  (" & Cancel & ")"
    
    Label1.Caption = sObjName
    Label2.Caption = sWheelRot
    Label3.Caption = sCtrlKey
    Label4.Caption = sCurX
    Label5.Caption = sCurY
    Label6.Caption = sCancelScrol
End Sub
 
Hi Fullerm
Have you tried the code in post#38?
Does that one work for you without isuues ?

@Jaafar Tribak I have just tried this code again from post #38 and on a Windows 10 x64 machine, when I scroll down with my mouse, the ListBox scrolls UP! (scroll up with the mouse does scroll up the list box as it should)
Are you able to provide some help?
 
Upvote 0

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
@Jaafar Tribak
I'm trying to find an answer for mouse wheel scrolling on a userform in word and I thought your code from post 38 & 44 would do it but I can't seem to get it working. I'm working on office 2013 32 bit, win 10 if relevant.

This is what I've done so far, have I missed something obvious?
- Copied the basMain module
- Copied the Min, Max, Match functions in to the basMain module.
- Replaced the Application.Min/Max/Match calls with the function (ie .ScrollTop = Max(0, .ScrollTop - SCROLL_CHANGE))
- Declared IgnoreList()
- Added the IgnoreList and EnableWheelScroll lines to my userform_activate
- Copied the OnMouseWheelScroll sub to my userform as per below.
VBA Code:
Public Sub OnMouseWheelScroll(ByVal obj As Object, ByVal WheelRotation As WHEEL_ROTATION, _
    ByVal CtrlKey As CTRL_KEY_PRESS_STATE, ByVal x As Long, ByVal y As Long, Cancel As Boolean)
    '
    ''SET THE CANCEL ARG TO TRUE TO DISABLE WHEEL-SCROLLING IF DESIRED.
    '
    Debug.Print obj.Name & vbTab & WheelRotation & vbTab & CtrlKey & vbTab & x & vbTab & y
    '
End Sub

It's not currently throwing an error it just isnt scrolling at all. I did have to remove the 0 from the end of the match substitute:
Code:
If IsError(ValueExistsInArray(TypeName(oTempCtrl), IgnoreList, 0)) Then
as there was an error for too many arguments.

I'm hoping I've just missed something simple, I cant post the document it's in but if necessary I can look at setting up a test document with the same code.
 
Upvote 0
Final update - Hoepfully, should address all the reported issues .

Workbook Update Demo


1- Main code in a Standard Module:
VBA Code:
'////////////////////////////////////////////////////////////////////////////////////////////
'//  CODE FOR ENABLING MOUSEWHEEL SCROLLING ON EXCEL USERFORMS AND ON ALL ITS CONTROLS.//////
'//  THIS GENERIC CODE RAISES A PSEUDO-EVENT "OnMouseWheelScroll"////////////////////////////
'//  THE PSEUDO-EVENT HANDLER IS LOCATED IN THE USERFORM MODULE AND IS DECLARED AS PUBLIC.///
'//  HOLD DOWN THE CTRL KEY FOR HORIZONTAL SCROLLING.////////////////////////////////////////
'//
'//  CODE BY JAAFAR TRIBAK AMENDED ON 27/11/2020 @ MrExcel.com'//////////////////////////////////////
'////////////////////////////////////////////////////////////////////////////////////////////

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

#If Win64 Then
    Private Type MSG
        hwnd As LongLong
        message As Long
        wParam As LongLong
        lParam As LongLong
        time As Long
        pt As POINTAPI
    End Type
#Else
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
#End If
    
#If VBA7 Then
    #If Win64 Then
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, 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 Any, pvarChild As Variant) As Long
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd 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 GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) 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 ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
#Else
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd 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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As any, pvarChild As Variant) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) 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 EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
#End If

Private bEnable As Boolean



Public Property Let EnableWheelScroll(ByVal UserForm As Object, Optional IgnoreList As Variant, ByVal Enable As Boolean)
    '======================
    'Arguments description:
    '======================
        '(1)- UserForm : UserForm object
        '-------------------------------
        '(2)- IgnoreList() : Array that contains the type of controls that should ignore the mouse-wheel.
            'These are typically controls that don't scroll like Commandbuttons, Labels, checkboxes etc..
        '------------------------------------------------------------------------------------------------
        '(3)- Enable : Toggles mousewheel scrolling On and Off.
        '------------------------------------------------------
    
    '/////////////////////////////////////////////////////////////
    '//  Scroll_Change for the UserForm ,Frames and MultiPages. //
    '//  Change the value of this Constant as required.         //
         Const SCROLL_CHANGE = 20                      '//
    '/////////////////////////////////////////////////////////////

    Const CHILDID_SELF = &H0&
    Const S_OK As Long = &H0
    Const WM_MOUSEWHEEL = &H20A
    Const WHEEL_DELTA = 120
    Const PM_REMOVE = &H1
    Const MK_CONTROL = &H8
    Const POINTSPERINCH As Long = 72
    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
 
    
    #If Win64 Then
        Dim hwnd As LongLong, Ptr As LongLong
    #Else
        Dim hwnd As Long
    #End If
    
    Dim oCollection As New Collection
    Dim WheelRotation As WHEEL_ROTATION
    Dim CtrlKey As CTRL_KEY_PRESS_STATE
    Dim tMsg As MSG
    Dim tCurPos As POINTAPI
    Dim oIA As IAccessible, oIACtrl As IAccessible, oIAPage As IAccessible
    Dim oTempCtrl As Control, oCtrl As Control, oTempPage As Control
    Dim objUnderMouse As Object
    Dim vKid  As Variant
    Dim lLeft As Long, lTop As Long, lResult As Long, i As Long
    Dim bCancel As Boolean


    On Error Resume Next
    
    bEnable = Enable
    
    Call IUnknown_GetWindow(UserForm, VarPtr(hwnd))

    'START THE LOOP.
    Do While bEnable
    
        DoEvents
        'RETRIEVE AND STORE THE LOCATION OF EACH CONTROL.
        For Each oIACtrl In UserForm.Controls
            Set oTempCtrl = oIACtrl
            If IsError(Application.Match(TypeName(oTempCtrl), IgnoreList, 0)) Then
                Call oIACtrl.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF)
                If TypeName(oTempCtrl) = "MultiPage" Then
                    Set oIAPage = oTempCtrl.Pages(oTempCtrl.Value)
                    Call oIAPage.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF)
                    Set oTempPage = oIAPage
                    oCollection.Add oTempPage, CStr(lLeft & lTop & oTempCtrl.Name & oTempCtrl.Pages(oTempCtrl.Value).Caption)
                End If
                oCollection.Add oTempCtrl, CStr(lLeft & lTop)
            End If
        Next
        
        'RETRIEVE THE LOCATION OF THE CONTROL CURRENTLY UNDER THE MOUSE POINTER.
        GetCursorPos tCurPos
        #If Win64 Then
            Call CopyMemory(Ptr, tCurPos, LenB(tCurPos))
            lResult = AccessibleObjectFromPoint(Ptr, oIA, vKid)
        #Else
            lResult = AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
        #End If
        
        If lResult = S_OK Then
            Call oIA.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF)
            Set objUnderMouse = oCollection.Item(lLeft & lTop)
            For Each oCtrl In UserForm.Controls
                If TypeName(oCtrl) = "MultiPage" Then
                    Set objUnderMouse = oCollection.Item(lLeft & lTop & oCtrl.Name & oCtrl.Pages(oCtrl.Value).Caption)
                End If
            Next
            If oIA.accName(CHILDID_SELF) = UserForm.Caption Then Set objUnderMouse = UserForm
            
            'WAIT FOR A MOUSEWHEEL-SCROLL AND RAISE THE SCROLL PSEUDO-EVENT WHEN IT HAPPENS.
            If Not objUnderMouse Is Nothing Then
                Call WaitMessage
                If PeekMessage(tMsg, hwnd, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
                
                CtrlKey = IIf(loword(CLng(tMsg.wParam)) = MK_CONTROL, Pressed, Released)
        
                If (hiword(CLng(tMsg.wParam)) / WHEEL_DELTA) > 0 Or (hiword(CLng(tMsg.wParam)) = WHEEL_DELTA) Then
                    WheelRotation = Forward
                Else
                    WheelRotation = Backward
                End If
                    
                    'RAISE THE PSEUDO-SCROLL EVENT LOCATED IN THE USERFORM MODULE.
                    Call UserForm.OnMouseWheelScroll(objUnderMouse, WheelRotation, CtrlKey, tCurPos.X - lLeft, tCurPos.Y - lTop, bCancel)
                    
                    'IF SCROLL EVENT NOT CANCELED FOR THE CURRENT CONTROL, GO AHEAD AND IMPLEMENT THE SCROLLING.
                    If Not bCancel Then
                    
                        If TypeName(objUnderMouse) = "TextBox" Then
                            With objUnderMouse
                                .SetFocus
                                If i = 0 Then
                                    .SelStart = 0
                                Else
                                    .SelStart = IIf(.SelStart = .LineCount, 0, .SelStart)
                                End If
                                If WheelRotation = Forward Then
                                    .CurLine = .CurLine - 1
                                Else
                                    .CurLine = IIf(.CurLine = .LineCount - 1, .CurLine, .CurLine + 1)
                                End If
                            End With
                            i = i + 1
                        End If
                        
                        If TypeName(objUnderMouse) = "ScrollBar" Then
                            With objUnderMouse
                                If WheelRotation = Forward Then
                                    .Value = IIf(.Value - objUnderMouse.SmallChange > .Min, .Value - objUnderMouse.SmallChange, .Min)
                                Else
                                    .Value = IIf(.Value + objUnderMouse.SmallChange < .Max, .Value + objUnderMouse.SmallChange, .Max)
                                End If
                            End With
                        End If
                        
                        If TypeName(objUnderMouse) = "ListBox" Or TypeName(objUnderMouse) = "ComboBox" Then
                        
                            With objUnderMouse
                                If CtrlKey = Released Then
                                    If WheelRotation = Forward Then
                                    .TopIndex = .TopIndex - 1
                                    Else
                                    .TopIndex = .TopIndex + 1
                                    End If
                                Else
                                    .SetFocus
                                    If WheelRotation = Forward Then
                                        SendKeys "{LEFT}", True
                                        DoEvents
                                        SendKeys "{RIGHT}", True
                                    Else
                                        SendKeys "{RIGHT}", True
                                        DoEvents
                                        SendKeys "{RIGHT}", True
                                    End If
                                End If
                            End With
                            
                        End If
                        
                        
                        If TypeName(objUnderMouse) <> "ComboBox" Then
                        
                            Call EnumWindows(AddressOf HideDropDown, ByVal 0)
                        
                        End If
                        
                        
                        With objUnderMouse 'USERFORM, FRAMES AND MULTIPGES.
                            If CtrlKey = Released Then
                                If WheelRotation = Forward Then
                                    .ScrollTop = Application.Max(0, .ScrollTop - SCROLL_CHANGE)
                                Else
                                    .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE)
                                End If
                            Else
                                If WheelRotation = Forward Then
                                    .ScrollLeft = Application.Max(0, .ScrollLeft - SCROLL_CHANGE)
                                Else
                                    .ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE)
                                End If
                            End If
                        End With
                    End If
                End If
            End If
        End If
        bCancel = False
    Loop

End Property


Private Function loword(DWord As Long) As Integer
    If DWord And &H8000& Then
        loword = DWord Or &HFFFF0000
    Else
        loword = DWord And &HFFFF&
    End If
End Function

Private Function hiword(ByVal DWord As Long) As Integer
    hiword = (DWord And &HFFFF0000) \ &H10000
End Function


#If Win64 Then
    Private Function HideDropDown(ByVal hwnd As LongLong, ByVal lParam As Long) As Long
#Else
    Private Function HideDropDown(ByVal hwnd As Long, ByVal lParam As Long) As Long
#End If

    Dim sClassName As String * 256
    
    Call GetClassName(hwnd, sClassName, 256)
    If Left(sClassName, 11) = "F3 MdcPopup" Then
        Call ShowWindow(hwnd, 0)
        HideDropDown = 0
        Exit Function
    End If
    HideDropDown = 1

End Function


'------------------------------------------------------------------------------
''// THE FOLLOWING MOUSEWHEEL PSEUDO-EVENT HANDLER GOES IN THE USERFORM MODULE.
'------------------------------------------------------------------------------

    'Public Sub OnMouseWheelScroll(ByVal obj As Object, ByVal WheelRotation As WHEEL_ROTATION, _
    'ByVal CtrlKey As CTRL_KEY_PRESS_STATE, ByVal X As Long, ByVal Y As Long, Cancel As Boolean)
    '
    ''SET THE CANCEL ARG TO TRUE TO DISABLE WHEEL-SCROLLING IF DESIRED.
    '
    'Debug.Print obj.Name & vbTab & WheelRotation & vbTab & CtrlKey & vbTab & X & vbTab & Y
    '
    'End Sub
'--------------------------------------------------------------------------------------------------




2- Code Usage Example (UserForm Module)
VBA Code:
Option Explicit

Private IgnoreList() As Variant


Private Sub UserForm_Activate()

    Me.TextBox1.SelStart = 0
    
    'These controls ignore the mousewheel scrolling.
    'Add & remove from array to suit.
    IgnoreList = Array("Label", "CommandButton", "ToggleButton", "CheckBox", "OptionButton", "Image", "SpinButton")
    
    EnableWheelScroll(Me, IgnoreList) = True
End Sub

Private Sub UserForm_Terminate()

    EnableWheelScroll(Me) = False
    
    With Sheet1
        .Range("a10").ClearContents
        .Range("a13").ClearContents
        .Range("a16").ClearContents
        .Range("a19").ClearContents
        .Range("a22").ClearContents
        .Range("a25").ClearContents
    End With
End Sub


Private Sub CommandButton1_Click()
    Unload Me
End Sub



'--------------------
'Public Generic event
'--------------------
'Set the Cancel Argument to TRUE to disable scrolling

Public Sub OnMouseWheelScroll(ByVal obj As Object, ByVal WheelRotation As WHEEL_ROTATION, _
ByVal CtrlKey As CTRL_KEY_PRESS_STATE, ByVal X As Long, ByVal Y As Long, Cancel As Boolean)

    'If obj Is Frame1  Then Cancel = True
    
    With Sheet1
        If TypeName(obj) = "Page" Then
            .Range("a10") = obj.Parent.Name & "." & obj.Name
        Else
            .Range("a10") = obj.Name
        End If
        .Range("a13") = IIf(WheelRotation = Forward, "Forward", "Backward")
        .Range("a16") = IIf(CtrlKey = Pressed, "Pressed", "Released")
        .Range("a19") = IIf(CtrlKey = Pressed, "Horizontal", "Vertical")
        .Range("a22") = X
        .Range("a25") = Y
    End With

'    Debug.Print obj.Name & vbTab & WheelRotation & vbTab & CtrlKey & vbTab & X & vbTab & Y
End Sub
 
Upvote 0
Thanks for the update @Jaafar Tribak . I tried the new code in Word and am still getting stuck on the following line of code in basMain. I'm still using the substituted functions from post 44.
If IsError(ValueExistsInArray(TypeName(oTempCtrl), IgnoreList, 0)) Then

Results in:
Error
Compile error
Type mismatch: array or user-defined type expected

Are you able to assist? Thanks again.
 
Upvote 0
Thanks for the update @Jaafar Tribak . I tried the new code in Word and am still getting stuck on the following line of code in basMain. I'm still using the substituted functions from post 44.
If IsError(ValueExistsInArray(TypeName(oTempCtrl), IgnoreList, 0)) Then

Results in:
Error
Compile error
Type mismatch: array or user-defined type expected

Are you able to assist? Thanks again.
Can you upload a copy of your word document to some file sharing website and post a link here so I can take a look ?
 
Upvote 0
Jaafar, this is awesome and a really clever implementation. It does have some performance issues and doesn't allow for smooth scrolling, and as the other person having issues within the use of worksheet formulas like match, min and max make it Excel only. I'd also consider a delimiter between the left and top coordinates as can have conflicting keys x10, y122 ='s x101, y22.

This thread was my first google hit while trying to find a solution, and I played around with it for a while.

Just for others who also looking for a solution, who can work past the testing. It's worth noting if your run debugging break points during certain hook points, it can cause crashes, I've been commenting out while developing.
 
Upvote 0
Hello everyone, first post! Have been using the knowledge in these forums for sometime without being registered.

Jaafar, your API based solutions are wonderful. I have used a couple of your code on my last project.

One of them is making a bitmap file to use on MultiPages. Just modified it, so I only create a 1x1 pixel bmp file rather than one that is the size of the userform since I was using stretching.

Also, this one, mouse wheel on userforms. The problems I have faced were:

1. When you have a couple of MultiPages nested with a frame I couldn't make your code work (maybe I couldn't understand the code much at that time). Example would be:
Chart Interface.JPG
2. I have some controls that are on top of each other, top left corners overlapping. This resulted in the control being reported being wrong.
3. Just as some others have mentioned, the movement would always be downward. I have MS365/ 64-bit OS/ 64-bit Excel.

I have overcame all these by modifying your code. I would like to share my experience.
1 & 2. Instead of getting the locations of each control on every Do While cycle, I placed a 6x6 pts label that is the same color as the MultiPage backcolor. I only check if it is still where it was last time, and only get the new locations if it is not. This has helped with the performance issues that some others reported. Only 2-3% CPU load (when code is running but idle otherwise) iirc. I have 700+ controls on the userform I linked above. And it performs much more stuff than just the wheel for me at the moment.
3. I used the following functions instead of the loword/hiword you provided. Mind you I am not in any way knowledgeable in these, I may be doing something wrong but it works.

VBA Code:
Private Function LoWord32(ByVal wParam As Long) As Integer
    
    Call CopyMemory(LoWord32, ByVal VarPtr(wParam), 2)

End Function

Private Function HighWord32(ByVal wParam As Long) As Integer
    
    Call CopyMemory(HighWord32, ByVal VarPtr(wParam) + 2, 2)

End Function

Private Function LoWord64(ByVal wParam As LongPtr) As Long
    
    Call CopyMemory(LoWord64, ByVal VarPtr(wParam), 2)

End Function

Private Function HighWord64(ByVal wParam As LongPtr) As Long
    
    Call CopyMemory(HighWord64, ByVal VarPtr(wParam) + 2, 2)
    
End Function

And, where I check for mouse wheel rotation:

VBA Code:
#If Win64 Then
    If HighWord64(tMsg.wParam) > (2 ^ 15) Then
        If (HighWord64(tMsg.wParam) - (2 ^ 16)) < 0 Then
            WheelRotation = Backward
        End If
    ElseIf HighWord64(tMsg.wParam) > 0 Then
        WheelRotation = Forward
    End If
#Else
    If HighWord32(CLng(tMsg.wParam)) > 0 Then
        WheelRotation = Forward
    Else
        WheelRotation = Backward
    End If
#End If

Oh! And I removed anything involving ignore list and use it like a normal sub. The next screenshot needs a lot of work just to be fair.
LazyD Thanks.JPG

By the way, your personal website is not working at this time.
 
Upvote 0
Sorry, can't find an edit button. I would like to add since I have overlapping controls, I used
Code:
Call oIACtrl.accLocation(lLeft, lTop, lWidth, lHeight, CHILDID_SELF)
 
Upvote 0
@Gokhan Aycan

Thanks for letting us know how you overcame the issues you encountered and hope it will be of use to others.
Applying this looping code to a big number of controls specially nested controls can easily get confusing and possibly get out of control.
 
Upvote 0
Just remembered: When the code is running, VeryHidden sheets do show up in hidden sheets list. Can anyone confirm is it so or due to some change I have made to the original code?
 
Upvote 0

Forum statistics

Threads
1,223,214
Messages
6,170,771
Members
452,353
Latest member
strainu

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