Excel 如何在大型工作表上的无模式vba用户窗体中的控件上实现响应鼠标悬停效果

我有下面的代码，它在正常的VBA用户窗体上运行得非常好：每当鼠标悬停在标签上的任何位置时，标签的颜色都是红色，否则就是白色。这种效果非常灵敏，使标签感觉非常像按钮

带有1个标签的用户表单的代码：

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

鼠标悬停效果仍然有效，但它变得非常迟钝和无反应。看来刷新率已经大幅下降

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

我的问题是:

是否有可能在非模态用户窗体中实现模态用户窗体的行为？ 我在寻找操纵无模式用户表单刷新率的方法，但没有找到任何有用的方法

另一种解决方案是，在模式模式下显示Userform时，可以在工作表中滚动

---

另一种解决方案可能是，当鼠标在其上时使UserForm为模态，当鼠标离开某个区域（UserForm边框）时使其为非模态。这可能吗？

编辑：经过一天的反复试验，我找到了一个简单的解决方案 现在，我将描述简单的解决方案，并将之前发现的复杂解决方案留在下面，作为替代方案

简易解决方案： 首先，我们需要从Windows API获取睡眠函数：

#If Win64 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#If Win32 Then
    Public Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
#End If

注意：仅针对32位Office进行测试，但也应适用于64位

其次，我们声明一个布尔值，它将指示UserForm当前是打开的还是关闭的：

Public UF1open As Boolean

最后，我们在Userforms激活事件中包含以下代码：

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

以及UserForms Terminate事件中的以下内容：

Private Sub UserForm_Terminate()
    UF1open = False
End Sub

下面是我提出的第一个复杂而困难的解决方案：

这使用我最后提出的解决方案想法解决了问题。 我使Userform在鼠标位于Userform区域时自动进入模态，并在鼠标离开Userform区域时自动进入非模态。这样做需要一组API函数。 以下不是最干净的代码，也不是很稳定（粗心的错误处理），但证明了这一概念：

这是用于调用UserForm的模块：

Option Explicit


#If Win32 Then
    Public Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
    Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
    Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Declare Function GetDeviceCaps Lib "Gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
#End If

Const LogPixelsX = 88
Const LogPixelsY = 90
Public Type PointAPI
    x As Long
    y As Long
End Type

Public ufXposScreen As Long
Public ufYposScreen As Long
Public ufXposVBA As Long
Public ufYposVBA As Long
Public ufXpos2Screen As Long
Public ufYpos2Screen As Long
Public ufXpos2VBA As Long
Public ufYpos2VBA As Long

Public UFname As String
Public JustStarted As Boolean 'to catch the first time a function is called
Public ModleS As Boolean 'indicate whether the UF is currently moedless or not


Sub loader()
#If Win64 Then
    MsgBox "Sorry 64 bit not supported"
    Exit Sub
#End If
    ModleS = False
    JustStarted = True
    UserForm1.Show

End Sub


Public Function IsLoaded(formName As String) As Boolean 'returns if UF is currently loaded or not
Dim frm As Object
For Each frm In VBA.UserForms
    If frm.Name = formName Then
        IsLoaded = True
        Exit Function
    End If
Next frm
IsLoaded = False
End Function
Public Function pointsPerPixelX() As Double 'Used for transforming windows API Mouse-coordinates to vba coordinates
    Dim hDC As Long
    hDC = GetDC(0)
    pointsPerPixelX = 72 / GetDeviceCaps(hDC, LogPixelsX)
    ReleaseDC 0, hDC
End Function
Public Function pointsPerPixelY() As Double 'Used for transforming windows API Mouse-coordinates to vba coordinates
    Dim hDC As Long
    hDC = GetDC(0)
    pointsPerPixelY = 72 / GetDeviceCaps(hDC, LogPixelsY)
    ReleaseDC 0, hDC
End Function
Public Function GetX() As Long 'Get current X coordinate of Mouse
    Dim n As PointAPI
    GetCursorPos n
    GetX = n.x
End Function
Public Function GetY() As Long 'Get current y coordinate of Mouse
    Dim n As PointAPI
    GetCursorPos n
    GetY = n.y
End Function
Public Sub WaitSeconds(sngSeconds As Single) 'sub pausing application for given value of seconds
    On Error GoTo errHand
    Dim s As Single
    s = Timer + sngSeconds
    Do
        Sleep 1  'this correlates to the "refresh rate" of the mouseover effect, sleep 100 leads to sluggish behaviour
        DoEvents
    Loop Until Timer >= s

Done:
    Exit Sub

errHand:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , "modDateTime.WaitSeconds"
    Resume Done
End Sub
Public Sub RunAllTime(ByRef UF As Object)
            '// this sub is called in the uf_activate event and loops
            '// all the time. if the mouse leaves the uf area if makes
            '// the userform go modeless, if the mouse reenters the area
            '// the sub exits, but not before using uf.show to make the
            '// uf modal again. uf.show automatically recalls this sub
            '// because of the activate event.

Dim x As Long
Dim y As Long

If JustStarted Then
    UFname = UF.Name
    JustStarted = False
End If

Do
    WaitSeconds 0.5

    If IsLoaded(UFname) = False Then
        End
    End If

    x = GetX()
    y = GetY()

    With UF
        If .Left <> ufXposVBA Or .Top <> ufYposVBA Or (.Left + .Width) <> ufXpos2VBA Or (.Top + .Height) <> ufYpos2VBA Then
            ufXposVBA = .Left
            ufYposVBA = .Top
            ufXposScreen = .Left / pointsPerPixelX()
            ufYposScreen = .Top / pointsPerPixelY()
            ufXpos2VBA = .Left + .Width
            ufYpos2VBA = .Top + .Height
            ufXpos2Screen = (.Left + .Width) / pointsPerPixelX()
            ufYpos2Screen = (.Top + .Height) / pointsPerPixelY()
        End If
        If ModleS = False Then
            If x < ufXposScreen Or x > ufXpos2Screen Or y < ufYposScreen Or y > ufYpos2Screen Then
                UF.Hide
                UF.Show vbModeless
                ModleS = True
            End If
        Else
            If x > ufXposScreen And x < ufXpos2Screen And y > ufYposScreen And y < ufYpos2Screen Then
                UF.Hide
                ModleS = False
                UF.Show
                Exit Sub
            End If
        End If
    End With
Loop

End Sub

---

如果有人对此感兴趣，并设法找到更好的解决方案，或可以改进我的代码，请张贴在这里

编辑：经过一天的反复试验，我找到了一个简单的解决方案 现在，我将描述简单的解决方案，并将之前发现的复杂解决方案留在下面，作为替代方案

简易解决方案： 首先，我们需要从Windows API获取睡眠函数：

#If Win64 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#If Win32 Then
    Public Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
#End If

注意：仅针对32位Office进行测试，但也应适用于64位

其次，我们声明一个布尔值，它将指示UserForm当前是打开的还是关闭的：

Public UF1open As Boolean

最后，我们在Userforms激活事件中包含以下代码：

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

以及UserForms Terminate事件中的以下内容：

Private Sub UserForm_Terminate()
    UF1open = False
End Sub

下面是我提出的第一个复杂而困难的解决方案：

这使用我最后提出的解决方案想法解决了问题。 我使Userform在鼠标位于Userform区域时自动进入模态，并在鼠标离开Userform区域时自动进入非模态。这样做需要一组API函数。 以下不是最干净的代码，也不是很稳定（粗心的错误处理），但证明了这一概念：

这是用于调用UserForm的模块：

Option Explicit


#If Win32 Then
    Public Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
    Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
    Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Declare Function GetDeviceCaps Lib "Gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
#End If

Const LogPixelsX = 88
Const LogPixelsY = 90
Public Type PointAPI
    x As Long
    y As Long
End Type

Public ufXposScreen As Long
Public ufYposScreen As Long
Public ufXposVBA As Long
Public ufYposVBA As Long
Public ufXpos2Screen As Long
Public ufYpos2Screen As Long
Public ufXpos2VBA As Long
Public ufYpos2VBA As Long

Public UFname As String
Public JustStarted As Boolean 'to catch the first time a function is called
Public ModleS As Boolean 'indicate whether the UF is currently moedless or not


Sub loader()
#If Win64 Then
    MsgBox "Sorry 64 bit not supported"
    Exit Sub
#End If
    ModleS = False
    JustStarted = True
    UserForm1.Show

End Sub


Public Function IsLoaded(formName As String) As Boolean 'returns if UF is currently loaded or not
Dim frm As Object
For Each frm In VBA.UserForms
    If frm.Name = formName Then
        IsLoaded = True
        Exit Function
    End If
Next frm
IsLoaded = False
End Function
Public Function pointsPerPixelX() As Double 'Used for transforming windows API Mouse-coordinates to vba coordinates
    Dim hDC As Long
    hDC = GetDC(0)
    pointsPerPixelX = 72 / GetDeviceCaps(hDC, LogPixelsX)
    ReleaseDC 0, hDC
End Function
Public Function pointsPerPixelY() As Double 'Used for transforming windows API Mouse-coordinates to vba coordinates
    Dim hDC As Long
    hDC = GetDC(0)
    pointsPerPixelY = 72 / GetDeviceCaps(hDC, LogPixelsY)
    ReleaseDC 0, hDC
End Function
Public Function GetX() As Long 'Get current X coordinate of Mouse
    Dim n As PointAPI
    GetCursorPos n
    GetX = n.x
End Function
Public Function GetY() As Long 'Get current y coordinate of Mouse
    Dim n As PointAPI
    GetCursorPos n
    GetY = n.y
End Function
Public Sub WaitSeconds(sngSeconds As Single) 'sub pausing application for given value of seconds
    On Error GoTo errHand
    Dim s As Single
    s = Timer + sngSeconds
    Do
        Sleep 1  'this correlates to the "refresh rate" of the mouseover effect, sleep 100 leads to sluggish behaviour
        DoEvents
    Loop Until Timer >= s

Done:
    Exit Sub

errHand:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , "modDateTime.WaitSeconds"
    Resume Done
End Sub
Public Sub RunAllTime(ByRef UF As Object)
            '// this sub is called in the uf_activate event and loops
            '// all the time. if the mouse leaves the uf area if makes
            '// the userform go modeless, if the mouse reenters the area
            '// the sub exits, but not before using uf.show to make the
            '// uf modal again. uf.show automatically recalls this sub
            '// because of the activate event.

Dim x As Long
Dim y As Long

If JustStarted Then
    UFname = UF.Name
    JustStarted = False
End If

Do
    WaitSeconds 0.5

    If IsLoaded(UFname) = False Then
        End
    End If

    x = GetX()
    y = GetY()

    With UF
        If .Left <> ufXposVBA Or .Top <> ufYposVBA Or (.Left + .Width) <> ufXpos2VBA Or (.Top + .Height) <> ufYpos2VBA Then
            ufXposVBA = .Left
            ufYposVBA = .Top
            ufXposScreen = .Left / pointsPerPixelX()
            ufYposScreen = .Top / pointsPerPixelY()
            ufXpos2VBA = .Left + .Width
            ufYpos2VBA = .Top + .Height
            ufXpos2Screen = (.Left + .Width) / pointsPerPixelX()
            ufYpos2Screen = (.Top + .Height) / pointsPerPixelY()
        End If
        If ModleS = False Then
            If x < ufXposScreen Or x > ufXpos2Screen Or y < ufYposScreen Or y > ufYpos2Screen Then
                UF.Hide
                UF.Show vbModeless
                ModleS = True
            End If
        Else
            If x > ufXposScreen And x < ufXpos2Screen And y > ufYposScreen And y < ufYpos2Screen Then
                UF.Hide
                ModleS = False
                UF.Show
                Exit Sub
            End If
        End If
    End With
Loop

End Sub

---

如果有人对此感兴趣，并设法找到更好的解决方案，或可以改进我的代码，请张贴在这里

我在模态和非模态之间没有不同的行为。当您显示表单无模式时，是否有其他代码正在运行，但在显示模式时没有运行？2013年，只有给定的代码没有重新编译，这两种情况下的行为都相同。没有，即使在我使用的简单示例中，如果工作簿完全为空，并且除了此代码之外，没有其他代码，则会变得缓慢。你知道我可以尝试更改哪些设置吗？我的处理器是一个8GB内存的核心i7 8550U，我使用Office32Bitoh，当我关闭除此之外的所有工作簿时，它也得到了响应。只有当我同时打开一个更大的工作簿时，问题才会出现！很抱歉，即使打开了几个工作簿和一个工作簿，我在其中启动了一些后台运行的代码，userform仍然可以正常工作。当您显示表单无模式时，是否有其他代码正在运行，但在显示模式时没有运行？2013年，只有给定的代码没有重新编译，这两种情况下的行为都相同。没有，即使在我使用的简单示例中，如果工作簿完全为空，并且除了此代码之外，没有其他代码，则会变得缓慢。你知道我可以尝试更改哪些设置吗？我的处理器是一个8GB内存的核心i7 8550U，我使用Office32Bitoh，当我关闭除此之外的所有工作簿时，它也得到了响应。只有当我同时打开一个更大的工作簿时，问题才会出现！很抱歉，即使打开了几个工作簿和一个工作簿，其中我在后台运行了一些代码，用户表单仍然可以正常工作。