Userform mouse scroll

Sort by date Sort by votes
My apologies for the delay - I've only just tried it now - I'm on 32bit office, Windows 10, and like Formula11, only the worksheet worked.
Microsoft® Excel® for Microsoft 365 MSO (Version 2301 Build 16.0.16026.20196) 32-bit
Click to expand...
 
Upvote 0

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Thanks guys for testing.

I am not sure as I dont have a pc within reach for testing properly but I suspect the issue lies in the HiWord and LoWord functions which I have now modified.

Please, would you download this new test workbook and let me know if it fixes the issue.
 
Upvote 0
Certainly. Will do before I go to work tomorrow
 
Upvote 0
Can you please remove the On Error Resume Next statement located at the start of the loop to see if you do get an error and if you do, which error it is.

In excel 2019 x64bit, the code errors out at the line :
VBA Code: 
 Call oForm.UserForm_WheelScroll _
                     (x, y, lRotations, lWheelScrollLines, _
                     IIf(lAccumulatedDelta > 0&, Forward, Backward), CBool(lVKey = MK_CONTROL))
with Error# 438 'Object doesn't support this Property or Method'.

For some reason, the Public UserForm_WheelScroll pseudo event handler procedure that is located inside each UserForm module is not being recognised ! This only happened in Excel 2019. The code worked OK in excel 2007,2010,2013 and 2016 regardless of bitness.

From, what I can see, the problem is not with the code not picking up the WM_MOUSEWHEEL message as I had initially thought. The issue looks more like a bug\peculiarity in excel 2019.

I see that you both have Excel 365 but I don't have office 365 myself so I can't test... The issue you are experiencing is probably the same one I describe above happening in excel 2019.

Again, thank you both for testing.
 
Upvote 0
Formula11 said:
Hi Jaafar, confirm that error does occur, as described.
Click to expand...
Ok thanks.

In that case, we shall remove the scroll event handlers from each userform module and we shall replace them with one single scroll event handler which will be placed in the standard api module... This single event handler will now be shared by all the userforms.

But the now shared scroll event handler should have a way of knowing which userform is currently calling it... In order to accomplish this, we will simply add a new argument to the event handler procedure (Form argument - first one)

The event signature will now look as follows :
VBA Code: 
Private Sub UserForm_WheelScroll_Event( _
    ByVal Form As Object, _
    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 _
)

Here is the new test workbook UserFormsMouseWheelSharedEvent.xlsm along with other whistles and bells... If this fixes the issue, I will post the entire code here later on for future reference.

Thanks.
 
Last edited:
Upvote 0
Jaafar, this seems to work, and there are no issues so far.
Thank you again for the effort as it looks like it's taken a lot of work to code.
Cheers.
 
Upvote 0
Formula11 said:
Jaafar, this seems to work, and there are no issues so far.
Click to expand...
Perfect (y)

Thank you again for the effort as it looks like it's taken a lot of work to code.
Click to expand...
I wanted to get to the bottom of this once and or all, as I remember some users reporting similar issues in old threads also dealing with the topic of mousewheel scrolling.

For future reference, I am re-posting the code of the entire vbaproject because the class modules have also slightly changed:

Download:
UserFormsMouseWheelSharedEvent.xlsm


1- CControlEvents Class:
VBA Code: 
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


Public Sub HookControls( _
    ByVal Form As Object, _
    ByVal bHook As Boolean _
)

    Dim oCtrlEvents As CControlEvents
    Dim oMPEvents As CMultiPageEvents
    Dim oCtrl As Object
  
    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
  
    Set Form = Nothing
    Set oMPEvents = Nothing
    Set oCtrl = Nothing
    Set oCtrlEvents = Nothing

End Sub

Private Property Let SetControlEvents( _
    ByVal 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
  
    Set Ctrl = Nothing
    Set oSinkClass = Nothing
  
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



2- CMultiPageEvents Class:
VBA Code: 
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


Public Property Let SetControlEvents( _
    ByVal 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
  
    Set Ctrl = Nothing
    Set oSinkClass = Nothing

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



3- API code in a Standard Module ( including the shared pseudo-event)
VBA Code: 
Option Explicit

#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 Enum SCROLL_DIRECTION
    Forward
    Backward
End Enum

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 bLooping As Boolean


Public Property Let EnableMouseWheelScroll(ByVal Form As Object, ByVal vNewValue As Boolean)
    Dim oCtrlEvents As CControlEvents
    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 Integer, lAccumulatedDelta  As Long, lRotations As Long
    Dim lVKey As Integer, 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 = HwndToDispatch(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(tMsg.wParam)
                lVKey = LoWord(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 UserForm_WheelScroll_Event _
                     (oForm, X, Y, lRotations, lWheelScrollLines, _
                     IIf(lAccumulatedDelta > 0&, Forward, Backward), CBool(lVKey = MK_CONTROL))
            End If
        End If
  
        Set oPrevForm = oForm
        DoEvents
    Loop
  
    Set oForm = Nothing
    Set oPrevForm = Nothing
    bLooping = False

End Sub

Private Function HwndToDispatch(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 HwndToDispatch = oForm
                End If
            End If
        End If
    End If

End Function

Private Function HiWord(Param As LongPtr) As Integer
    Call CopyMemory(HiWord, ByVal VarPtr(Param) + 2&, 2&)
End Function

Private Function LoWord(Param As LongPtr) As Integer
    Call CopyMemory(LoWord, ByVal VarPtr(Param), 2&)
End Function




'________________________________________ MOUSEWHEEL SCROLL PSEUDO-EVENT __________________________________

Private Sub UserForm_WheelScroll_Event( _
    ByVal Form As Object, _
    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 _
)
  
    With Form
        If CtrlKeyPressed = False Then
            .ScrollTop = .ScrollTop + IIf(ScrollDirection = Backward, WheelScrollLines, -WheelScrollLines)
        Else
            .ScrollLeft = .ScrollLeft + IIf(ScrollDirection = Backward, WheelScrollLines, -WheelScrollLines)
        End If
      
        .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 With

End Sub



4- Code Usage in the UserForm(s) Module:
VBA Code: 
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
 
Upvote 0
I apologise about cluttering the thread with repetitive posts/codes but I had to add one final touch namely, the ability to toggle the mouse wheel scrolling on/off at runtime (ie: Offering the user, the ability to flexibly enable/disable scrolling after the userforms are already loaded).

Added new Boolean Property (IsMouseWheelScrollEnabled) and made use of the userforms Tag Property.

Download:
UserFormsMouseWheelSharedEvent_LastVersion.xlsm


1- CControlEvents Class:
VBA Code: 
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 Object

Public Sub HookControls( _
    ByVal Form As Object, _
    ByVal bHook As Boolean _
)

    Dim oCtrlEvents As CControlEvents
    Dim oMPEvents As CMultiPageEvents
    Dim oCtrl As Object
   
    If bHook Then
        For Each oCtrl In Form.Controls
            If TypeName(oCtrl) = "MultiPage" Or TypeName(oCtrl) = "TabStrip" Then
                Set oMPEvents = New CMultiPageEvents
                oMPEvents.SetControlEvents(Form, oMPEvents, oCtrl) = True
            Else
                Set oCtrlEvents = New CControlEvents
                SetControlEvents(Form, oCtrlEvents, oCtrl) = True
            End If
        Next
    End If
   
    Set Form = Nothing
    Set oMPEvents = Nothing
    Set oCtrl = Nothing
    Set oCtrlEvents = Nothing

End Sub

Private Property Let SetControlEvents( _
    ByVal Form As Object, _
    ByVal 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
   
    Set oForm = Form
    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
   
    Set Ctrl = Nothing
    Set oSinkClass = Nothing
   
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(oForm)
End Sub

Private Sub Class_Terminate()
    Set oForm = Nothing
End Sub



2- CMultiPageEvents Class:
VBA Code: 
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 Object

Public Property Let SetControlEvents( _
    ByVal Form As Object, _
    ByVal 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
   
    Set oForm = Form
   
    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
   
    Set Ctrl = Nothing
    Set oSinkClass = Nothing

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(oForm)
End Sub

Private Sub Class_Terminate()
    Set oForm = Nothing
End Sub



3- API code in a Standard Module ( Including the mouse wheel scroll pseudo event)
VBA Code: 
Option Explicit

#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 Enum SCROLL_DIRECTION
    Forward
    Backward
End Enum

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 bLooping As Boolean


Public Property Let EnableMouseWheelScroll(ByVal Form As Object, ByVal vNewValue As Boolean)
    Dim oCtrlEvents As CControlEvents
    If vNewValue Then
        Set oCtrlEvents = New CControlEvents
        Form.Tag = "Scrolling_Enabled"
        Call oCtrlEvents.HookControls(Form, True)
    Else
        Form.Tag = ""
    End If
End Property

Public Property Get IsMouseWheelScrollEnabled(ByVal Form As Object) As Boolean
    IsMouseWheelScrollEnabled = CBool(Form.Tag = "Scrolling_Enabled")
End Property


Public Sub MonitorMouseWheel(ByVal Form As Object)
    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 Integer, lAccumulatedDelta  As Long, lRotations As Long
    Dim lVKey As Integer, 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 = HwndToDispatch(GetAncestor(hwnd, GA_ROOT))
        Call IUnknown_GetWindow(oForm, VarPtr(hwnd))
       
        If Not (oPrevForm Is Nothing) _
           And Not (oPrevForm Is oForm) _
           Or IsMouseWheelScrollEnabled(oForm) = False 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(tMsg.wParam)
                lVKey = LoWord(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 UserForm_WheelScroll_Event _
                     (oForm, X, Y, lRotations, lWheelScrollLines, _
                     IIf(lAccumulatedDelta > 0&, Forward, Backward), CBool(lVKey = MK_CONTROL))
            End If
        End If
   
        Set oPrevForm = oForm
        DoEvents
    Loop
   
    Set oForm = Nothing
    Set oPrevForm = Nothing
    bLooping = False

End Sub

Private Function HwndToDispatch(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 HwndToDispatch = oForm
                End If
            End If
        End If
    End If

End Function

Private Function HiWord(Param As LongPtr) As Integer
    Call CopyMemory(HiWord, ByVal VarPtr(Param) + 2&, 2&)
End Function

Private Function LoWord(Param As LongPtr) As Integer
    Call CopyMemory(LoWord, ByVal VarPtr(Param), 2&)
End Function



'________________________________________ MOUSEWHEEL SCROLL PSEUDO-EVENT __________________________________

Private Sub UserForm_WheelScroll_Event( _
    ByVal Form As Object, _
    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 _
)
   
    With Form
        If CtrlKeyPressed = False Then
            .ScrollTop = .ScrollTop + IIf(ScrollDirection = Backward, WheelScrollLines, -WheelScrollLines)
        Else
            .ScrollLeft = .ScrollLeft + IIf(ScrollDirection = Backward, WheelScrollLines, -WheelScrollLines)
        End If
       
        .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 With

End Sub



4- Code Usage example in the UserForm(s) Module:
VBA Code: 
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(Me)
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
Create Vertical Scrolling Text in UserForm
2
Replies
12
Views
230
Fluff
Fluff
A
  • Question
What is wrong with this VBA code: userForm get hand ico for pointer on hover
2
Replies
15
Views
590
RoryA
RoryA
N
  • Question
Excel ink picture sheet (not userform) is not drawing
Replies
0
Views
252
nd0911
N
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
341
huiettcm
H
N
  • Question
Unable to scroll in a single tab - Not a scroll lock issue
Replies
2
Views
1K
Nordicrx8
N

Forum statistics

Threads
1,215,621
Messages
6,125,884
Members
449,268
Latest member
sGraham24

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top