How to achieve a responsive mouseover effect on Controls in a modeless vba Userform on a large Worksheet

I have the following code, which works perfectly fine on a normal VBA Userform: whenever the mouse hovers anywhere over the label, the color of said label is red, otherwise it's white. This effect is very responsive and makes the label feel very Button-like.

Code of the Userform with 1 label on it:

Dim active As Boolean

Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If active = False Then
        Label1.BackColor = RGB(255, 0, 0)
        active = True
    End If
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If active = True Then
        Label1.BackColor = RGB(255, 255, 255)
        active = False
    End If
End Sub

If i change the UserForm to be called modeless, from a module like this:

Sub loader()
    UserForm1.Show vbModeless
End Sub

The Mouseover effect still works but it becomes very sluggish and unresponsive. It seems like the refreshrate has gone down massively.

Edit: I found out this problem only appears when the Active Worksheet is a big one, which obviously slows everything down a bit. The sheet that gives me headaches has around 1000 rows and 50 columns with many cells containing longer strings. I think the sheet itself is around 1MB of Data. Forumlas are set to manual refresh only. I'm on a Laptop with an i7 8550U and 8GB of ram using Office 32 bit.

My question is:

Is it possible to achieve the behaviour of the modal Userform in the modeless one? I looked for ways to manipulate the refreshrate of a modeless Userform but couldn't find anything helpful.

An alternative solution would be to make scrolling in the Worksheet possible while the Userform is shown in modal mode.

Another solution might be making the UserForm modal while the mouse is on it and modeless once the mouse leaves a certain area (the UserForm borders). Is that possible?

Solution

Solution 1 - recommended

Add the following code to your UserForm:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
#End If

Dim m_isOpen As Boolean

Private Sub UserForm_Activate()
    m_isOpen = True
    Do While m_isOpen
        Sleep 15  'this correlates to the "refresh rate" of the mouseover effect,
        DoEvents  'sleep 100 leads to sluggish behaviour
    Loop
End Sub

Private Sub UserForm_Terminate()
    m_isOpen = False
End Sub

The mouseover effect should now be responsive again.

Solution 2

This is an implementation of the last of my proposed solution ideas. It will make the UserForm automatically go modal while the mouse is inside the area of the UserForm and go modeless once the mouse leaves this zone. Just add this code to a plain UserForm:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
#Else
    Private Public Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
    Private Public Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetDeviceCaps Lib "Gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
#End If

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90

Private Type PointAPI
    x As Long
    y As Long
End Type

Dim m_modal As Boolean
Dim m_modalityIndicator As Object

Private Function pointsPerPixelX() As Double
    Dim hdc As LongPtr      'Used for transforming windows API Mouse-coordinates
    hdc = GetDC(0)          'to vba coordinates
    pointsPerPixelX = 72 / GetDeviceCaps(hdc, LOGPIXELSX)
    ReleaseDC 0, hdc
End Function

Private Function pointsPerPixelY() As Double
    Dim hdc As LongPtr      'Used for transforming windows API Mouse-coordinates
    hdc = GetDC(0)          'to vba coordinates
    pointsPerPixelY = 72 / GetDeviceCaps(hdc, LOGPIXELSY)
    ReleaseDC 0, hdc
End Function

Private Function GetX() As Long 'Get current X coordinate of Mouse
    Dim n As PointAPI
    GetCursorPos n
    GetX = n.x
End Function

Private Function GetY() As Long 'Get current y coordinate of Mouse
    Dim n As PointAPI
    GetCursorPos n
    GetY = n.y
End Function

Sub MonitorMouse()
    Dim x As Long, y As Long
    
    On Error GoTo userform_closed
    Do While True
        Sleep 15: DoEvents
        x = GetX(): y = GetY()
        With Me
            If m_modal Then
                If x < .left / pointsPerPixelX() Or _
                   x > (.left + .Width) / pointsPerPixelX() Or _
                   y < .top / pointsPerPixelY() Or _
                   y > (.top + .Height) / pointsPerPixelY() Then
                    .Hide
                    .show vbModeless
                    m_modal = False
                End If
            Else
                If x > .left / pointsPerPixelX() And _
                   x < (.left + .Width) / pointsPerPixelX() And _
                   y > .top / pointsPerPixelY() And _
                   y < (.top + .Height) / pointsPerPixelY() Then
                    .Hide
                    m_modal = True
                    .show
                    Exit Sub
                End If
            End If
        End With
    Loop
    Exit Sub
userform_closed:
    err.Clear: On Error GoTo 0
End Sub

Private Function isFormModeless() As Boolean
    On Error GoTo EH
    Me.show vbModeless: isFormModeless = True
    Exit Function
EH:
    isFormModeless = False
End Function

Private Sub UserForm_Activate()
    If isFormModeless Then
        m_modalityIndicator.Caption = "modeless"
    Else
        m_modalityIndicator.Caption = "modal"
    End If

    MonitorMouse
End Sub

Private Sub UserForm_Initialize()
    Set m_modalityIndicator = Me.Controls.Add("Forms.Label.1", "ModalityIndicator", True)

    With m_modalityIndicator
        .left = Me.left
        .top = Me.top
        .Width = Me.Width
        .Height = Me.Height
        .Font.size = 36
    End With
End Sub