如何在Excel上保持多个无模式VBA窗体的运行

如何在Excel上保持多个无模式VBA窗体同时运行

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

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

有没有办法让这两个非模态表单都运行

表1

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

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

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

此工作簿

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

UserForm1

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

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

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

选项显式
以单人身份开始私人旅行
私有倒计时活动为布尔值
私有子cmdContinue_Click（）
出错时继续下一步
Application.OnTime EarliestTime:=NextCheck，过程：=“超时”，计划：=False
LastEdit=Int（计时器）
倒计时活动=假
卸下我
端接头
私有子用户表单_Activate（）
调试。打印此工作簿。名称&“-CountDownActive:&CountDownActive
如果未激活倒计时，则开始倒计时
端接头
私有子用户表单_Terminate（）
出错时继续下一步
Application.OnTime EarliestTime:=NextCheck，过程：=“超时”，计划：=False
LastEdit=Int（计时器）
NextCheck=DateAdd（“s”，检查间隔，现在）
Application.OnTime EarliestTime:=NextCheck，过程：=“超时”，计划：=True
调试。打印“NextCheck for”&此工作簿。名称&“-”&NextCheck
端接头
私有子StartCountDown（）
倒计时活动=真
开始=计时器
Do While Timer-StartTotalIdleTime-countdown
Me.Caption=Format（时间序列（0,0，countdown-Timer+Start），“nn:ss”）&“关闭前剩余时间”&&thishworkbook.Name&“…”
多芬特
环
如果Timer-LastEdit>TotalIdleTime-CountDownTime，则
Application.DisplayAlerts=False
此工作簿。关闭错误
Application.DisplayAlerts=True
如果结束
倒计时活动=假
卸下我
端接头

模块1

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

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

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

选项显式
公共LastEdit作为单个
公共NextCheck As Date
公共常数检查间隔=60'“00:01:00”
公共常数TotalIdleTime=180’“00:03:00”
公共常数CountDownTime=120英寸“00:02:00”
私有函数超时（）
出错时继续下一步
作为对象的Dim IdleTimerForm
选择案例计时器-LastEdit
案例为

---

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

我现在无法证实我的怀疑，但我猜测使用

用户表单的全局实例是造成问题的原因。试着用
Set someUFVar=new userform
实例化一个新的用户表单这实际上也是我的第一个猜测，我试过了，但没用。无论如何，谢谢。你能把你的问题包括在倒计时代码中吗？@Chronocidal code added添加了更多的代码，我确实在一个空工作簿中复制了它。还有两个问题,；1） 只有最新计数器持续运行2）关闭最新工作簿将从所有打开的工作簿中卸载所有用户表单。我现在无法确认我的怀疑，但我猜测使用
用户表单的全局实例是造成问题的原因。试着用
Set someUFVar=new userform
实例化一个新的用户表单这实际上也是我的第一个猜测，我试过了，但没用。无论如何，谢谢。你能把你的问题包括在倒计时代码中吗？@Chronocidal code added添加了更多的代码，我确实在一个空工作簿中复制了它。还有两个问题,；1） 只有最新计数器保持运行2）关闭最新工作簿将从所有打开的工作簿中卸载所有用户表单。