1

如何让多个无模式 VBA 表单在 Excel 上同时运行？

当工作簿长时间处于非活动状态时，我有一个使用 UserForm.Show(False) 弹出的无模式表单。表单有一个超时计数器，如果在计数器达到零之前它没有被用户中断（用户表单卸载），那么工作簿就会关闭。在 UserForm_Activate 中有一个 Do While - 带有 DoEvents 的循环以显示表单中的剩余时间。

这适用于单个打开的工作簿。但是，如果我复制 xlsm 文件并打开它们，那么在指定的空闲时间之后，两个工作簿都会打开它们的超时表单，但只有最后一个的计数器会运行。打开第二个表格后，第一个表格的计数器将停止。

有什么方法可以让两种无模式表单都运行？

表 1

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    LastEdit = Int(Timer)
End Sub

本工作簿

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=False
End Sub

Private Sub Workbook_Open()
    NextCheck = DateAdd("s", CheckInterval, Now)
    Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=True
    Debug.Print "NextCheck for " & ThisWorkbook.Name & " - " & NextCheck
    LastEdit = Int(Timer)
End Sub

用户窗体1

Option Explicit

Private Start As Single
Private CountDownActive As Boolean

Private Sub cmdContinue_Click()
    On Error Resume Next
    Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=False
    LastEdit = Int(Timer)
    CountDownActive = False
    Unload Me
End Sub

Private Sub UserForm_Activate()
    Debug.Print ThisWorkbook.Name & " - CountDownActive: " & CountDownActive
    If Not CountDownActive Then StartCountDown
End Sub

Private Sub UserForm_Terminate()
    On Error Resume Next
    Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=False
    LastEdit = Int(Timer)
    NextCheck = DateAdd("s", CheckInterval, Now)
    Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=True
    Debug.Print "NextCheck for " & ThisWorkbook.Name & " - " & NextCheck
End Sub

Private Sub StartCountDown()
    CountDownActive = True
    Start = Timer
    Do While Timer - Start < CountDownTime And Timer - LastEdit > TotalIdleTime - CountDownTime
        Me.Caption = Format(TimeSerial(0, 0, CountDownTime - Timer + Start), "nn:ss") & " remaining until closing '" & ThisWorkbook.Name & "'..."
        DoEvents
    Loop
    If Timer - LastEdit > TotalIdleTime - CountDownTime Then
        Application.DisplayAlerts = False
        ThisWorkbook.Close False
        Application.DisplayAlerts = True
    End If
    CountDownActive = False
    Unload Me
End Sub

模块1

Option Explicit

Public LastEdit As Single
Public NextCheck As Date

Public Const CheckInterval = 60         ' "00:01:00"
Public Const TotalIdleTime = 180        ' "00:03:00"
Public Const CountDownTime = 120        ' "00:02:00"

Private Function TimeOut()
    On Error Resume Next
    Dim IdleTimerForm As Object
    Select Case Timer - LastEdit
        Case Is < TotalIdleTime - CountDownTime
            Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=False
            NextCheck = DateAdd("s", CheckInterval, Now)
            Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=True
            Debug.Print "NextCheck for " & ThisWorkbook.Name & " - " & NextCheck
        Case Else
            Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=False
            Call AppActivate(Application.Caption)
            ThisWorkbook.Activate
            Set IdleTimerForm = New UserForm1
            IdleTimerForm.Show vbModeless
    End Select
End Function

还有一个问题是，当用户表单计数器之一达到零并卸载表单时，它将从每个当前打开的工作簿中卸载该用户表单的所有实例。

4

0 回答 0