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

Question

我有以下代码，它在普通 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

鼠标悬停效果仍然有效，但变得非常缓慢且无响应。好像刷新率大幅下降了。

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

我的问题是：

是否可以在无模式用户窗体中实现模式用户窗体的行为？我寻找了操纵无模式用户窗体刷新率的方法，但找不到任何有用的方法。

另一种解决方案是在用户窗体以模态模式显示时使工作sheet中的滚动成为可能。

另一种解决方案可能是在鼠标悬停在用户窗体上时使用户窗体成为模态，而在鼠标离开某个区域（用户窗体边界）后成为无模式。这可能吗？

Answer 1

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

简单的解决方案： 1st 我们需要从 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 位

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

Public UF1open As Boolean

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

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

以及用户窗体终止事件中的以下内容：

Private Sub UserForm_Terminate()
    UF1open = False
End Sub

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

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

这是调用用户窗体的模块：

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

这是用户表单的代码：

Dim active As Boolean

Private Sub UserForm_Initialize()
    With UserForm1
        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 With
End Sub

Private Sub UserForm_Activate()
    RunAllTime UserForm1
End Sub

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

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

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

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

excel

vba

userform