Userform mouse scroll

[Formula11]

I tried a few code snippets for scrolling a userform with mouse wheel.
So far this has worked.
How to use the mousewheel with a scrollbar control

Is it possible to allow scroll only when mouse hovers over the form?
- 64-bit
- Form is vbModeless

 

[Formula11]

This works before and up to initial hover on the form.

But there is no event when mouse moves away from the form.
The x and y is supposed to check if hovering but not working.

Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    HookFormScroll Me
    If ((x < 0) Or (y < 0) Or (x > Me.Width) Or (y > Me.Height)) Then
        UnhookFormScroll
    End If
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    UnhookFormScroll
End Sub

 

[Dan_W]

Because if the mouse isn't over the userform, the movemousevent won't be triggered at all, much less return an X or Y in excess of the Userforms width/height.

 

[Formula11]

Thanks Dan_W, tried below code, it works OK for a large form size but wasn't very responsive for a small form.

    If ((x < Me.Width - Me.InsideWidth) Or (y < Me.Height - Me.InsideHeight) Or (x > Me.InsideWidth) Or (y > Me.InsideHeight)) Then
        UnhookFormScroll
    End If

 

[Jaafar Tribak]

I would be wary using that windows mousewheel hook, specially when applied to a modeless userform due to the great potential for crashing the entire application... A safer alternative is to use the PeekMessage api to monitor/handle incoming WM_MOUSEWHEEL messages. Do a search for that api as this topic has been addressed here before.

As for stopping the hook when the mouse leaves the userform, there is no such *mouse_leave* event but the code can be easily adapted to detect when the mouse is outside the form area ( WindowFromPoint or AccessibleObjectFromPoint or even the excel RangeFromPoint Method) all can be used.

 

[Formula11]

Thanks Jaafar, I'll look into this, as I did try several code snippets and most were crashing Excel.

 

[Jaafar Tribak]

Here is a new and safer approach for eanabling mouse scrolling. One special feature about this code is that it works on multiple loaded UserForms simultaneously. Furthermore, the code allows for scrolling the userform even when the mouse hovers over controls within the userform and not just when the mouse hovers over the userform's empty client area.

Obviously, all the above could be achieved by installing a system-wide mouse hook with much lesser code than the approach I am taking up here but, installing a windows hook in this particular scenario would seriously compromise the safety of the entire excel application and could cause a nasty GPF crash ... Using the approach I have taken up here is safe and, at least, it won't cause excel to shut down and lose any unsaved work should an unhandled error occur.

For easy use, I have designed the code in a fashion that mimics native events therefore, each UserForm contains its own *copy* of the UserForm_WheelScroll Pseudo-Event inside its own module and, all the necessary scroll info is carried in the event arguments.

Note: To scroll horizonally, hold the CTRL key down.


Download:
MouseWheelScrollVariousUserForms.xlsm








Here is the entire code for future reference:

1- CControlEvents Class:

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0& To 7&) As Byte
End Type

#If VBA7 Then
    Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As LongPtr) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As Long
#Else
    Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As GUID) As Long
#End If

Private oForm As MSForms.UserForm, oMPEvents As CMultiPageEvents


Public Sub HookControls( _
    ByVal Form As MSForms.UserForm, _
    ByVal bHook As Boolean _
)
    Dim oCtrlEvents As CControlEvents
    Dim oCtrl As MSForms.Control
 
    Set oForm = Form
    If bHook Then
        For Each oCtrl In Form.Controls
            If TypeName(oCtrl) = "MultiPage" Or TypeName(oCtrl) = "TabStrip" Then
                Set oMPEvents = New CMultiPageEvents
                oMPEvents.SetControlEvents(oMPEvents, oCtrl) = True
            Else
                Set oCtrlEvents = New CControlEvents
                SetControlEvents(oCtrlEvents, oCtrl) = True
            End If
        Next
    End If
 
End Sub

Private Property Let SetControlEvents( _
    oSinkClass As Object, _
    ByVal Ctrl As Object, _
    ByVal SetEvents As Boolean _
)
    Const S_OK = &H0
    Const IDISPATCH = "{00020400-0000-0000-C000-000000000046}"
    Static lCookie As Long
    Dim tIID As GUID
 
    If IIDFromString(StrPtr(IDISPATCH), tIID) = S_OK Then
        Call ConnectToConnectionPoint(oSinkClass, tIID, SetEvents, Ctrl, lCookie)
        If lCookie Then
            'Debug.Print "Connection set for: " & Ctrl.Name
        Else
            'Debug.Print "Connection failed for: " & Ctrl.Name
        End If
    End If
End Property


Public Sub OnMouseMove_DoNotUse( _
    ByVal Button As Integer, _
    ByVal Shift As Integer, _
    ByVal X As Single, _
    ByVal Y As Single _
)
    'Attribute OnMouseMove_DoNotUse.VB_UserMemId = -606
     Call MonitorMouseWheel
End Sub

Private Sub Class_Terminate()
    Set oMPEvents = Nothing
    Set oForm = Nothing
End Sub

2- CMultiPageEvents Class:

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0& To 7&) As Byte
End Type

#If VBA7 Then
    Private Declare PtrSafe Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As LongPtr) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As Long
#Else
    Private Declare Function ConnectToConnectionPoint Lib "shlwapi" Alias "#168" (ByVal punk As stdole.IUnknown, ByRef riidEvent As GUID, ByVal fConnect As Long, ByVal punkTarget As stdole.IUnknown, ByRef pdwCookie As Long, Optional ByVal ppcpOut As Long) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As GUID) As Long
#End If

Private oForm As MSForms.UserForm

Public Property Let SetControlEvents( _
    oSinkClass As Object, _
    ByVal Ctrl As Object, _
    ByVal SetEvents As Boolean _
)
    Const S_OK = &H0
    Const IDISPATCH = "{00020400-0000-0000-C000-000000000046}"
    Static lCookie As Long
    Dim tIID As GUID
 
    If IIDFromString(StrPtr(IDISPATCH), tIID) = S_OK Then
        Call ConnectToConnectionPoint(oSinkClass, tIID, SetEvents, Ctrl, lCookie)
        If lCookie Then
            'Debug.Print "Connection set for: " & Ctrl.Name
        Else
            'Debug.Print "Connection failed for: " & Ctrl.Name
        End If
    End If
End Property

Public Sub OnMouseMove_DoNotUse( _
    ByVal Index As Long, _
    ByVal Button As Integer, _
    ByVal Shift As Integer, _
    ByVal X As Single, _
    ByVal Y As Single _
)
    'Attribute OnMouseMove_DoNotUse.VB_UserMemId = -606
     Call MonitorMouseWheel
End Sub

Private Sub Class_Terminate()
    Set oForm = Nothing
End Sub

3- API code bas module:

Option Explicit

Public Enum SCROLL_DIRECTION
    Forward
    Backward
End Enum

#If VBA7 Then
  #If Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongLong
    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function 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 ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hUF As LongPtr, ByVal gaFlags As Long) As LongPtr
    Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hClient As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hClient As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As LongPtr
    Private Declare PtrSafe Function ObjectFromLresult Lib "oleacc" (ByVal lResult As LongPtr, riid As Any, ByVal wParam As LongPtr, ppvObject As Any) As Long

#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare 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 Function WaitMessage Lib "user32" () As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare Function GetAncestor Lib "user32" (ByVal hUF As LongPtr, ByVal gaFlags As Long) As LongPtr
    Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hClient As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hClient As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As LongPtr
    Private Declare Function ObjectFromLresult Lib "oleacc" (ByVal lResult As LongPtr, riid As Any, ByVal wParam As LongPtr, ppvObject As Any) As Long
#End If

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type Msg
    hwnd As LongPtr
    message As Long
    wParam As LongPtr
    lParam As LongPtr
    time As Long
    pt As POINTAPI
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0& To 7&) As Byte
End Type

Private oCtrlEvents As CControlEvents
Private bLooping As Boolean



Public Property Let EnableMouseWheelScroll(ByVal Form As Object, ByVal vNewValue As Boolean)
    Set oCtrlEvents = New CControlEvents
    Call oCtrlEvents.HookControls(Form, True)
End Property

Public Sub MonitorMouseWheel(Optional ByVal bDummy As Boolean)
    If bLooping = False Then
        Call MonitorWheel
    End If
End Sub


Private Sub MonitorWheel()

    Const WHEEL_DELTA = 120&, MK_CONTROL = &H8, WM_MOUSEWHEEL = &H20A, SPI_GETWHEELSCROLLLINES = &H68
    Const PM_NOREMOVE = &H0, GA_ROOT = 2&
 
    Dim lDelta As Long, lAccumulatedDelta  As Long, lRotations As Long
    Dim lVKey As Long, lWheelScrollLines As Long
    Dim hwnd As LongPtr
    Dim oForm As Object, oPrevForm As Object
    Dim tMsg As Msg, tCurPos As POINTAPI
    Dim X As Long, Y As Long


    Do
        On Error Resume Next
        Application.EnableCancelKey = xlDisabled
        bLooping = True
    
        Call GetCursorPos(tCurPos)
        #If Win64 Then
            Dim lPt As LongLong
            Call CopyMemory(lPt, tCurPos, LenB(lPt))
            hwnd = WindowFromPoint(lPt)
        #Else
            hwnd = WindowFromPoint(tCurPos.X, tCurPos.Y)
        #End If
        Set oForm = GetForm(GetAncestor(hwnd, GA_ROOT))
        Call IUnknown_GetWindow(oForm, VarPtr(hwnd))
    
        If Not (oPrevForm Is Nothing) And Not (oPrevForm Is oForm) Then
            Set oForm = oPrevForm
            Exit Do
        End If
            
        If hwnd Then
            Call WaitMessage
            If PeekMessage(tMsg, hwnd, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE) Then
        
                Call ScreenToClient(hwnd, tMsg.pt)
                X = tMsg.pt.X: Y = tMsg.pt.Y
                lDelta = HiWord(CLng(tMsg.wParam))
                lVKey = LoWord(CLng(tMsg.wParam))
            
                If lDelta * lAccumulatedDelta > 0& Then
                    lAccumulatedDelta = lAccumulatedDelta + lDelta
                Else
                    lAccumulatedDelta = lDelta
                End If
            
                If SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0&, lWheelScrollLines, 0&) = 0& Then
                    lWheelScrollLines = 3&
                End If
            
                lRotations = lAccumulatedDelta \ lDelta
                lRotations = IIf(lAccumulatedDelta > 0&, lRotations, -(lRotations))
            
                Call oForm.UserForm_WheelScroll _
                     (X, Y, lRotations, lWheelScrollLines, _
                     IIf(lAccumulatedDelta > 0&, Forward, Backward), (lVKey = MK_CONTROL))
            End If
        End If
 
        Set oPrevForm = oForm
        DoEvents
    Loop
            
    Set oCtrlEvents = Nothing
    bLooping = False

End Sub

Private Function GetForm(ByVal hwnd As LongPtr) As Object

    Const WM_GETOBJECT = &H3D&
    Const OBJID_CLIENT = &HFFFFFFFC
    Const GW_CHILD = 5
    Const S_OK = 0&
    Const IID_IDISPATCH = "{00020400-0000-0000-C000-000000000046}"
 
    Dim uGUID As GUID
    Dim oForm As Object
    Dim hClient As LongPtr, lResult As LongPtr
 
    hClient = GetNextWindow(hwnd, GW_CHILD)
    lResult = SendMessage(hClient, WM_GETOBJECT, NULL_PTR, ByVal OBJID_CLIENT)
    If lResult Then
        If IIDFromString(StrPtr(IID_IDISPATCH), uGUID) = S_OK Then
            If ObjectFromLresult(lResult, uGUID, NULL_PTR, oForm) = S_OK Then
                If Not oForm Is Nothing Then
                    Set GetForm = oForm
                End If
            End If
        End If
    End If

End Function

Private Function HiWord(DWord As Long) As Long
    HiWord = (DWord And &HFFFF0000) \ &H10000
End Function

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

- Code Usage example in the UserForms(s)

Option Explicit

Private Sub UserForm_Initialize()
    EnableMouseWheelScroll(Me) = True
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call MonitorMouseWheel
End Sub

'____________________________________ PSEUDO WHEEL SCROLL EVENT __________________________________
Public Sub UserForm_WheelScroll( _
    ByVal XPix As Long, _
    ByVal YPix As Long, _
    ByVal WheelRotations As Long, _
    ByVal WheelScrollLines As Long, _
    ByVal ScrollDirection As SCROLL_DIRECTION, _
    ByVal CtrlKeyPressed As Boolean _
    )

    If CtrlKeyPressed = False Then
        Me.ScrollTop = Me.ScrollTop + IIf(ScrollDirection = Backward, WheelScrollLines, -WheelScrollLines)
    Else
        Me.ScrollLeft = Me.ScrollLeft + IIf(ScrollDirection = Backward, WheelScrollLines, -WheelScrollLines)
    End If
 
    Me.Caption = "[XPix: " & XPix & "] [YPix: " & YPix & "]" & Space(2) & _
                 IIf(ScrollDirection = Backward, "[Backward]", "[Forward]") & Space(2) & _
                 IIf(CtrlKeyPressed, "[Horiz Scroll]", "[Vert Scroll]") & Space(2) & _
                 "[Rotations=" & WheelRotations & "]"

End Sub

 

[Formula11]

Thanks Jaafar, this looks like it took quite an effort.
The scroll didn't work on my system (Windows 10, Office 365). For the aspect of the scroll on hover, it was effective in the sense that the worksheet would only scroll when mouse was outside the form.

The following parts of the code were red in colour, in the bas_API module.

 

[Dan_W]

The red lines are normal. Provided the VBA interpreter isn't presenting error messages, and identifying those lines, some of the lines will always be red for most people, because that's code that won't run on their system. It doesn impact you, though, because of the IF ELSE statements.

 

[Jaafar Tribak]

The scroll didn't work on my system (Windows 10, Office 365).

I tested the code on another pc running Windows10 x64 excel 2019 x64 and it didn't work !
In fact, the WM_MOUSEWHEEL never gets picked up. Not sure why this is happening. Is it due to the system or due to the mouse driver.