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]

Hi Jaafar, thanks for posting with this option.
It didn't work on my system. As a test, I deleted the option for False and deleted new buttons, reopened workbook but still didn't work. I didn't compare the rest of the code relative to the one that worked.
Personally more than happy without the option to turn on/off.

 

[Jaafar Tribak]

Hi Jaafar, thanks for posting with this option.
It didn't work on my system. As a test, I deleted the option for False and deleted new buttons, reopened workbook but still didn't work. I didn't compare the rest of the code relative to the one that worked.
Personally more than happy without the option to turn on/off.

Thanks Formula11

Excel 2019 and 365 do some weird things . For some reason, unlike previous excel editions, they do not recognise some UserForm Properties such as the Tag Property when late binding the UserForm object.

Anyways, we can workaround the Tag Property issue by tagging the form window instead via the SetProp/GetProp/RemoveProp apis.

Here is the code now tested and working in excel 2019.
UserFormsMouseWheelSharedEvent_LastVersion.xlsm

 

[Formula11]

Thanks again Jaafar, I can confirm this now works.

 

[Jaafar Tribak]

Thanks again Jaafar, I can confirm this now works.

Thanks for the feedback and glad it worked for you in the end

 

[Dan_W]

I can confirm that it also works as intended on 32bit Office 365 (or whatever it's called now...)

 

[davsy]

Hi @Jaafar
Thanks you so much for this. But is there any way to use SPI_SETWHEELSCROLLLINES to set the number of scroll lines per scroll to make it scroll more lines?

 

[Jaafar Tribak]

@davsy

Thanks you so much for this. But is there any way to use SPI_SETWHEELSCROLLLINES to set the number of scroll lines per scroll to make it scroll more lines?

Don't use SPI_SETWHEELSCROLLLINES as this will affect the user's settings globally... Bad practice.

Fortunately, the mouse scroll pseudo event enables you to flexibly set the number of scroll lines per scroll. This is is done via the WheelScrollLines 5th argument.

Just set the value of the argument to whatever numbers of scroll lines you like at the start of the event handler as follows:

The following example sets the number of scrolllines to 20 lines per scroll.

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 _
)
 
    WheelScrollLines = 20&  '<== Set the mouse scroll value here as you like.
 
    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

 

[davsy]

@davsy

Don't use SPI_SETWHEELSCROLLLINES as this will affect the user's settings globally... Bad practice.

Fortunately, the mouse scroll pseudo event enables you to flexibly set the number of scroll lines per scroll. This is is done via the WheelScrollLines 5th argument.

Just set the value of the argument to whatever numbers of scroll lines you like at the start of the event handler as follows:

The following example sets the number of scrolllines to 20 lines per scroll.

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 _
)
 
    WheelScrollLines = 20&  '<== Set the mouse scroll value here as you like.
 
    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

Thanks @Jaafar !
Cheers!

 

[TomSHopping]

Hi @Jaafar Tribak! First, thank you very much for this new code contribution. I am one of the users who is working with one of your prior mouse scroll contributions in my forms. It works fairly well, but has a few glitches, such as the tab key no longer moving between controls, which I noted on some older threads last year.

I was very excited to try your new code! Unfortunately, it doesn't work for me... it compiles, I don't receive any errors, and it seems to be running, but nothing scrolls.

I do see the output of your .caption code at the top of my form to include number of rotations; it does detect the scrolling & mouse position.
I tried removing On Error Resume Next as noted above; no errors are returned.

Any other suggestions or things I can do to troubleshoot? Was there modified code related to the Tag Property issue/tagging the form window noted above? I'm using your code from Mar 16, 2023 (I paste everything in manually versus using your uploaded workbooks as I'm somewhere that blocks .xlsm downloads).

I'm on an Office 2016 license, but a very current build (Version 2305 Build 16501.20228 Click-to-Run).

Thanks again!

 

[Jaafar Tribak]

@TomSHopping

I paste everything in manually versus using your uploaded workbooks as I'm somewhere that blocks .xlsm downloads).

Here is the entire code that is contained in the last linked workbook (In Post#22)

1- Place this code in a Standard bas Module:

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
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
#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
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
#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
    Dim hwnd As LongPtr
    Call IUnknown_GetWindow(Form, VarPtr(hwnd))
    If vNewValue Then
        Set oCtrlEvents = New CControlEvents
        Call oCtrlEvents.HookControls(Form, True)
        Call SetProp(hwnd, "Scrolling_Enabled", -1)
    Else
        Call RemoveProp(hwnd, "Scrolling_Enabled")
    End If
End Property

Public Property Get IsMouseWheelScrollEnabled(ByVal hwnd As LongPtr) As Boolean
    IsMouseWheelScrollEnabled = CBool(GetProp(hwnd, "Scrolling_Enabled") = -1&)
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) _
           Or IsMouseWheelScrollEnabled(hwnd) = 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

2- Place this code in the UserForm Module:

Note:- this assumes you have already set up the ScrollHeight & ScrollWidth Properties to large values in order for the scrollbars of the UserForm to become visible... It also assumes you have two CommandButtons on the form for toggling the scrolling functionnality.

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

Private Sub CommandButton3_Click()
    'Disable mousewheel scroll.
    EnableMouseWheelScroll(Me) = False
End Sub

Private Sub CommandButton5_Click()
    'Enable mousewheel scroll.
    EnableMouseWheelScroll(Me) = True
End Sub

3- Copy the following code in NotePad, save it with Notepad as a text file with a CLS extention and then import the saved CLS file into your vbproject.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CControlEvents"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
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
    'Attribute OnMouseMove_DoNotUse.VB_UserMemId = -606
     Call MonitorMouseWheel
End Sub

4- Same as with Step 3 above, copy the following code in NotePad, save it with Notepad as a text file with a CLS extention and then import the saved CLS file into your vbproject.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CMultiPageEvents"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
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
    'Attribute OnMouseMove_DoNotUse.VB_UserMemId = -606
     Call MonitorMouseWheel
End Sub