Generic MouseWheel Scroll for UserForm and for ALL its Controls !

[Jaafar Tribak]

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 :

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:

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

 

[Jaafar Tribak]

I am not sure but if I comment out those lines, the scrolling dosen't work on the userform controls.

Not knowing your userform layaout it is difficult for me to tell but if it works for you, as you said, then good although it may hide a potential problem .

 

[ronrudman]

I have this code working - almost but not quite. I have a userform containing a frame, which in turn contains a long vertical list of labels that I need to scroll through.

In the activate event for my form, I call HookMouseWheelScroll Me. Then...
If I place my mouse pointer on the scroll bar, the mouse wheel works perfectly.
If I place my mouse pointer in the area between two labels, the mouse wheel works perfectly.
However, if I place my mouse pointer directly on a label, nothing happens when I use the scroll wheel.

In this case, I can see that objUnderMouse returns the Frame object as expected, but I can also see that the PeekMessage test returns FALSE.
I assume this means that the MOUSEWHEEL event is not occurring for the labels.

Can anyone suggest something I can try to get it to work for this case?

 

[Jaafar Tribak]

I have this code working - almost but not quite. I have a userform containing a frame, which in turn contains a long vertical list of labels that I need to scroll through.

In the activate event for my form, I call HookMouseWheelScroll Me. Then...
If I place my mouse pointer on the scroll bar, the mouse wheel works perfectly.
If I place my mouse pointer in the area between two labels, the mouse wheel works perfectly.
However, if I place my mouse pointer directly on a label, nothing happens when I use the scroll wheel.

In this case, I can see that objUnderMouse returns the Frame object as expected, but I can also see that the PeekMessage test returns FALSE.
I assume this means that the MOUSEWHEEL event is not occurring for the labels.

Can anyone suggest something I can try to get it to work for this case?

That's right - You can't scroll a Label but you could fake a label with a textbox

Try replacing the labels you want to scroll with textboxes .

To make the textboxes look and feel like labels, I would set their Locked Proprety to TRUE, backstyle to transparent, BorderStyle to Single and TabStop to FALSE... Not perfect as the user could still select the label text despite not being able to edit the label. This issue could be solved with some VBA code though.

See next post for an update of the code I posted in post#13 where I have corrected a couple of bugs and where I have added a new Textbox (Textbox8) that looks like a label and can be scrolled with the mose wheel.

 

[Jaafar Tribak]

workbook example update

 

[ronrudman]

That's right - You can't scroll a Label but you could fake a label with a textbox

Try replacing the labels you want to scroll with textboxes .

To make the textboxes look and feel like labels, I would set their Locked Proprety to TRUE, backstyle to transparent, BorderStyle to Single and TabStop to FALSE... Not perfect as the user could still select the label text despite not being able to edit the label. This issue could be solved with some VBA code though.

See next post for an update of the code I posted in post#13 where I have corrected a couple of bugs and where I have added a new Textbox (Textbox8) that looks like a label and can be scrolled with the mose wheel.

I'm sorry - I should have been clearer. I do not need the labels to scroll individually - I only need the list to scroll. I also omitted a possibly fatal fact: the labels are generated dynamically, long after the call to HookMouseWheelScroll. With these additional facts, would your suggestion about textboxes still apply?

 

[Jaafar Tribak]

I'm sorry - I should have been clearer. I do not need the labels to scroll individually - I only need the list to scroll. I also omitted a possibly fatal fact: the labels are generated dynamically, long after the call to HookMouseWheelScroll. With these additional facts, would your suggestion about textboxes still apply?

I see what you mean ... when pointing with the mouse over labels that are inside a frame or on the userform, the wheelsroll doesn't work.

Thanks for bringing this to my attention as this undesired effect can be very annoying.

I'll revise the code and see if I can fix this bug.

 

[Jaafar Tribak]

I see what you mean ... when pointing with the mouse over labels that are inside a frame or on the userform, the wheelsroll doesn't work.

Thanks for bringing this to my attention as this undesired effect can be very annoying.

I'll revise the code and see if I can fix this bug.

Hi rorudman,

I have re-written the code to fix the issue you experience.

The new code is smaller, more flexible and commented plus I have fixed many bugs and errors that went unnoticed in the initial code.

Public Property Let EnableWheelScroll(ByVal UserForm As Object, IgnoreList() As Variant, ByVal Enable As Boolean)

The code uses the Property EnableWheelScroll that takes an argument called IgnoreList() where the user can flexibly include the type of controls that will ignore the mousewheel scrolling

In your case, just add the control type ("Label") to the array before enabling the mousewheel.

Something like this in the activate event:

Private IgnoreList() As Variant

IgnoreList = Array("Label")
EnableWheelScroll(Me, IgnoreList) = True

I'll post the new code along with a workbook example in a bit.

The userform in the example workbook contains a list of labels inside a frame (frame9) which ignore the mousewheel and therefore it allows the container frame to scroll.

 

[Jaafar Tribak]

Workbook example

1- In a Standard Module :

[COLOR=#006400]'////////////////////////////////////////////////////////////////////////////////////////////
'//  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 ON 05/10/2018 @ MrExcel.com'//////////////////////////////////////
'////////////////////////////////////////////////////////////////////////////////////////////
[/COLOR]
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 LongToInteger
    Low As Integer
    High As Integer
End Type

[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  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 WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function 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)
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 Then
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
         Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    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 WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
 
Private Const CHILDID_SELF = &H0&
Private Const S_OK As Long = &H0
Private Const WM_MOUSEWHEEL = &H20A
Private Const PM_REMOVE = &H1
Private Const MK_CONTROL = &H8
Private Const POINTSPERINCH As Long = 72
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90

[COLOR=#008000]'/////////////////////////////////////////////////////////////
'//  Scroll_Change for the UserForm ,Frames and MultiPages. //
'//  Change the value of this Constant as required.         //
     [/COLOR]Private Const SCROLL_CHANGE = 20[COLOR=#008000]                      '//
'/////////////////////////////////////////////////////////////[/COLOR]

Private bEnable As Boolean


Public Property Let EnableWheelScroll(ByVal UserForm As Object, IgnoreList() As Variant, ByVal Enable As Boolean)
    [COLOR=#008000]'======================
    '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.
        '------------------------------------------------------[/COLOR]
    
    [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
            Dim Ptr As LongPtr
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
        Dim hwnd As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Dim hwnd As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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
    WindowFromAccessibleObject UserForm, hwnd


    [COLOR=#008000]'START THE LOOP.[/COLOR]
    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
        
        [COLOR=#008000]'RETRIEVE THE LOCATION OF THE CONTROL CURRENTLY UNDER THE MOUSE POINTER.[/COLOR]
        GetCursorPos tCurPos
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 And Win64 Then
            CopyMemory Ptr, tCurPos, LenB(tCurPos)
            lResult = AccessibleObjectFromPoint(Ptr, oIA, vKid)
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
            lResult = AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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
            
            [COLOR=#008000]'WAIT FOR A MOUSEWHEEL-SCROLL AND RAISE THE SCROLL PSEUDO-EVENT WHEN IT HAPPENS.[/COLOR]
            If Not objUnderMouse Is Nothing Then

                WaitMessage
                If PeekMessage(tMsg, hwnd, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
                
                    CtrlKey = IIf(LoWord(CLng(tMsg.wParam)) = MK_CONTROL, Pressed, Released)
                    WheelRotation = IIf(tMsg.wParam > 0, Forward, Backward)
                    
                    [COLOR=#008000]'RAISE THE PSEUDO-SCROLL EVENT LOCATED IN THE USERFORM MODULE.[/COLOR]
                    Call UserForm.OnMouseWheelScroll(objUnderMouse, WheelRotation, CtrlKey, tCurPos.X - lLeft, tCurPos.Y - lTop, bCancel)
                     
                    [COLOR=#008000]'IF SCROLL EVENT NOT CANCELED FOR THE CURRENT CONTROL, GO AHEAD AND IMPLEMENT THE SCROLLING.[/COLOR]
                    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
                        
                        With objUnderMouse [COLOR=#008000]'USERFORM, FRAMES AND MULTIPAGES.[/COLOR]
                            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(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 PXtoPT(ByVal Pixels As Single, ByVal bVert As Boolean) As Long
    PXtoPT = Pixels / ScreenDPI(bVert) * POINTSPERINCH
End Function



[COLOR=#008000]'------------------------------------------------------------------------------
''// 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
'--------------------------------------------------------------------------------------------------[/COLOR]

2- In the UserForm Module : (as per the workbook example)

Option Explicit

Private IgnoreList() As Variant

Private Sub UserForm_Activate()

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


Private Sub UserForm_Terminate()

    EnableWheelScroll(Me, IgnoreList) = 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

[B][COLOR=#008000]'--------------------
'Public Generic event
'--------------------
'Set the Cancel Argument to TRUE to disable scrolling.[/COLOR][/B]


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)

    [COLOR=#006400]'If obj Is Frame1  Then Cancel = True[/COLOR]
    
    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

 

[ronrudman]

Hi rorudman,

I have re-written the code to fix the issue you experience.

Thank you for posting this update, and I do apologize for taking so long to get back to it. It now works just beautifully for me except in one strange situation.

I have a case where a non-scrolling form has one scrolling frame. The frame has a few labels at the top and below them is a large image. If, when the form comes up, I immediately roll the mouse to the image, it does not scroll. However, if I first roll the mouse over a label (no click, no scroll wheel, just roll) and then roll it back to the image, the image DOES subsequently scroll as expected. I can see that the initial behavior is as though the object under the cursor is the form, rather than the frame, but after I roll over a label and return to the image, the object under the cursor is the frame.


My ignore list is set to: Array("Image", "Label", "CommandButton", "CheckBox", "OptionButton"). If it is relevant, there is only one control in oCollection: the frame.

I hope there is some simple workaround you can suggest for this - it's so close!

 

[ronrudman]

One other thing I've noticed is that if I click on the underlying sheet, then return focus to the userform, the form no longer scrolls. However, if I interact with the form, e.g., click a radio button, then the form scrolls properly.