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

 

[Gokhan Aycan]

I have a question:

Why not instead of:

#If Win64 Then
    Private Type MSG
        hwnd As LongLong
        message As Long
        wParam As LongLong
        lParam As LongLong
        time As Long
        pt As POINTAPI
    End Type
#Else
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
#End If

just use:

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

 

[Gokhan Aycan]

A couple more questions (all userforms modeless btw, atm testing with a single userform):

1- I notice there is a flickering "[running]" text, up in VBA Editor title bar. There is nothing running atm though (userform is hidden. I did notice this while using your "shape move event" code too. It would even hinder from using VBA Editor properly. So I just put in a check for a cell value to exit sub. So, what is actually running with these codes? Nothing in the call stack, and surely "Run" button is not greyed out.

Addition: Sometimes when I close with X (which actually hides with Me.Hide) it does stop running. Is there some kind of bug, would that constant running affect anything?

2- I was also using the previous DoLoop version for checking lots of other stuff happening with the workbook and worksheet. (Before I explore the possibilities myself) Can this be used for such purposes? Can it be modified to include also mouse move for example? Just exploring ideas, any insight is appreciated.

 

[Jaafar Tribak]

@Gokhan Aycan

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

That declaration won't work in excel 2007 and earlier versions and will immediately cause a compile error as the LongPtr var type wasn't introduced until VBA7 ie: until excel 2010 with the coming of Office x64bit.

Here is an alternative declaration that will also work without the use of Win64 or LongLong, but I prefer the first one.

#If VBA7 Then
    Private Type MSG
        hwnd As LongPtr
        message As LongPtr
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    End Type
#Else
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
#End If

Regarding the questions in your last post, which code are you referring to as there are so many in this thread it gets confusing?

 

[Gokhan Aycan]

Yeah, post #78. Also, another inquiry, when multiple modeless userforms are shown, would it be possible to the UF under to take focus? Add to that the sheet as well without having to click on them?

 

[Jaafar Tribak]

Yeah, post #78. Also, another inquiry, when multiple modeless userforms are shown, would it be possible to the UF under to take focus? Add to that the sheet as well without having to click on them?

The flickering "[running]" text, up in VBA Editor title bar is due to the Windows timer (SetTimer\TimerProc) constantly running in the background while the UserForm is loaded. That is expected.

Inevitably, using a timer as well as a DoLoop both have a performance hit on the application. Although I took care in the code of the most dangerous and annoying thing when using windows timers namely the risk of crashing the entire application, using a timer still has a a few other issues such as slightly slowing down the application as well as not being able to edit code until the timer or the DoLoop are stopped.

If you don't want to have all the above mentioned issues associated with Timers and DoLoops, you will need to run them from a separate thread or separate process. Multithreading doesn't work in vb but you can run the timer code from a dll loaded into the excel process or from a separate instance of excel but the code can be quite involved.

Here is an example where I run code from a sperate hidden instance of excel to intercept mouse clicks:

Nifty Class for Trapping Mouse Clicks on Cells

Hi all, There are times when excel users need to detect when a cell is being mouse-clicked ... The worksheet Selection_Change event is often used for this purpose but it has two main problems : A- it doesn't differenciate between keyboard and mouse selections B- It doesn't work if the same cell...

www.mrexcel.com

"Also, another inquiry, when multiple modeless userforms are shown, would it be possible to the UF under to take focus? Add to that the sheet as well without having to click on them?"
Can be done but that will be against the standard user interface experience and will feel unnatural.

 

[Gokhan Aycan]

I didn't check last night, the CPU usage is quite a lot. With the DoLoop code modified by me CPU is 2-3%, while Timer version sits around 37%. And doesn't exit consistently, keeps running in the background (I don't know if this would cause issues on a longer term, or some other issues. Also, coding can be tiresome). I tried with 1 and 2 userforms using it btw.

So, new question, would this be possible with DoLoop code?

Instead of collecting locations for a single UF, loop through all userforms that are visible and collect location info for controls, eliminating the need for constant enabling/disabling mouse wheel scroll checking during fast userform switching which could potentially eliminate my only issue with it.

Edit: I am starting to work on getting an answer to my question.

 

[Jaafar Tribak]

What DoLoop code do you have that uses 2-3% CPU ?

The screen location of each control changes when the userform is moved from its initial position hence the need for continious monitoring.

The timer code sets different timers one for each userform... This puts a lot of strain. I think, if we just had one timer procedure being shared between all the userforms , performance would improve.

The shared timer procedure would have to somehow figure out which userform is currently active (in the foreground) and direct its code to it.

BTW, are you using just one userform or more than one ?

EDIT: We could use the Deactivate event to kill the timers and resetting the timer in the Activate event.

 

[Jaafar Tribak]

Try adding this to each userform code module and see if performance improves :

Private Sub UserForm_Deactivate()
  EnableWheelScroll(Me) = False
End Sub

 

[Gokhan Aycan]

I tried the Timer version with both 1 and 2 userforms.

I believe a video would explain better. I didn't show multiple UFs, but the flow is like this:

- When a UF becomes with scrolling enabled active, its own procedure starts looping and a global shared boolean is set to true.
- UFs set this global to false on Deactivate events.
- If another UF with scrolling is activated, at the very top of its own procedure it checks for the global boolean, and App.OnTime itself with 2 seconds delay if already true, which means another UF's code is already running.

The above flow works, however, when UFs are activated in fast succession, can fail to engage the looping procedure.


Excel - MouseWheel Scrolling - DoLoop CPU Usage

 

[Jaafar Tribak]

@Gokhan Aycan

Thanks for the video.

That userform is quite complex with lots of tabs and controls.

Can you upload a workbook example for me so I can test it ... You don't need to upload your actual userform with the workbook , I just need the entire code that you are using and an empty userform. I can place some controls on the empty userform myself when I receive the workbook.

Regards.