如何在大型工作表上的无模式vba用户表单中实现对控件的响应鼠标覆盖效应

Question

我有以下代码，它在普通的VBA用户表单上非常好地工作:每当鼠标在标签上的任何地方盘旋，所述标签的颜色是红色的，否则它是白色的。这种效果反应迅速，使标签感觉很像按钮。

带有一个标签的Userform代码：

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

如果我从这样的模块中将UserForm更改为称为无模式的：

Sub loader()
    UserForm1.Show vbModeless
End Sub

Mouseover效应仍然有效，但它变得非常缓慢，反应迟钝。看来神清气爽的情绪已经大大下降了。

编辑：我发现只有在活动工作表很大时才会出现这个问题，这显然会使所有事情都慢下来。让我头疼的表格大约有1000行和50列，许多单元格包含较长的字符串。我认为表格本身大约是1MB的数据。论坛只设置为手动刷新。我在笔记本电脑上使用的是i7 8550 U和8GB内存，使用的是Office 32位。

我的问题是：

是否有可能在非模态中实现模态用户形式的行为？我寻找方法来操作非模态用户表单的刷新功能，但是找不到任何有用的东西。

另一种解决方案是使工作表中的滚动成为可能，而Userform则以模态模式显示。

另一种解决方案可能是在鼠标在其上时建立UserForm模式，并在鼠标离开某个区域( UserForm边界)时建立非模态。这有可能吗？

Answer 1

解决方案1-建议

将以下代码添加到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

鼠标覆盖效应现在应该可以再次响应了。

解决方案2

这是我最后一个提出的解决方案的实现。它将使UserForm在鼠标位于UserForm区域内时自动转到非模态状态，并在鼠标离开该区域后进行非模态操作。只需将此代码添加到普通的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