如何让Excel VBA子过程在工作簿运行期间持续执行并优化弹窗？

我编写了一个VBA子过程用于校验密码和预定义过期日期，但目前仅在Excel工作簿打开时生效。代码示例如下：

Private Sub Workbook_Open()

Dim j, i, trials, passCnt As Integer
trials = 3 'Number of trials
passCnt = 4 'Number of times to enter password
j = 1
ReDim AllPassWords(1 To trials) As String
AllPassWords(1) = "123"
AllPassWords(2) = "456"
AllPassWords(3) = "789"

ReDim ExpDate(1 To trials) As Date 'We pre-define the expiry dates and passwords
ExpDate(1) = CStr(DateSerial(2023, 1, 13) + TimeSerial(8, 49, 0))
ExpDate(2) = CStr(DateSerial(2023, 1, 13) + TimeSerial(8, 51, 0))
ExpDate(3) = CStr(DateSerial(2023, 1, 13) + TimeSerial(8, 53, 0))

Dim PassWord As String 'User password 

If CDate(Now) < ExpDate(j) Then 'If the jth trial has not expired we do the following

    If j = 1 Then
        For i = 1 To passCnt ' chances to enter password
            'Enter password before we can use the worksheet
            PassWord = InputBox("Please input password.")
            If PassWord = AllPassWords(j) Then
                
                Exit For
                
                ElseIf i < passCnt Then
                    MsgBox "Incorrect password. " & passCnt - i & " attempts remaining."
                
                ElseIf i = passCnt Then
                    MsgBox "Password limit reached. Closing workbook"
                    ThisWorkbook.Close
                
            End If
        Next i
    
    MsgBox ("You have " & ExpDate(j) - CDate(Now) & " days left")
        
    
    End If
    
    Else: MsgBox "Trial " & j & " has expired. New password will be required to continue"
        j = j + 1
End If

我需要实现两个需求：

1. 让这个校验过程在工作簿打开状态下持续运行，一旦过期日期到达，立即要求输入新密码，避免用户靠一直开着工作簿无限延长试用期限。
2. 不想代码每次执行都弹出MsgBox，只希望在工作簿打开时显示弹窗，后续监控过程静默运行。

核心思路 #

仅靠Workbook_Open只能触发一次校验，要实现持续监控必须用定时任务（Application.OnTime）循环检查过期时间；同时用模块级变量控制弹窗显示时机，只在启动时弹出，后续静默执行。

修改后的完整代码 #

将以下代码替换ThisWorkbook模块中的原有代码：

Option Explicit

' 模块级变量：控制弹窗显示、当前试用阶段、配置参数
Private isFirstRun As Boolean
Private currentTrial As Integer
Private trials As Integer
Private passCnt As Integer
Private AllPassWords() As String
Private ExpDate() As Date

Private Sub Workbook_Open()
    ' 初始化配置参数
    trials = 3
    passCnt = 4
    currentTrial = 1
    
    ' 初始化密码组
    ReDim AllPassWords(1 To trials) As String
    AllPassWords(1) = "123"
    AllPassWords(2) = "456"
    AllPassWords(3) = "789"
    
    ' 初始化过期时间（直接用日期类型，避免类型转换错误）
    ReDim ExpDate(1 To trials) As Date
    ExpDate(1) = DateSerial(2023, 1, 13) + TimeSerial(8, 49, 0)
    ExpDate(2) = DateSerial(2023, 1, 13) + TimeSerial(8, 51, 0)
    ExpDate(3) = DateSerial(2023, 1, 13) + TimeSerial(8, 53, 0)
    
    ' 标记首次运行，触发启动弹窗
    isFirstRun = True
    
    ' 启动首次校验和定时监控
    CheckExpiryAndAuth
End Sub

Private Sub CheckExpiryAndAuth()
    Dim PassWord As String
    Dim i As Integer
    
    ' 检查当前试用阶段是否过期
    If Now < ExpDate(currentTrial) Then
        ' 仅首次运行时显示密码输入和剩余时间弹窗
        If isFirstRun Then
            ' 密码校验流程
            For i = 1 To passCnt
                PassWord = InputBox("请输入密码。")
                If PassWord = AllPassWords(currentTrial) Then
                    MsgBox "您还剩 " & Format(ExpDate(currentTrial) - Now, "hh:mm:ss") & " 可用时间"
                    Exit For
                ElseIf i < passCnt Then
                    MsgBox "密码错误，还剩 " & passCnt - i & " 次尝试机会。"
                Else
                    MsgBox "密码尝试次数用完，即将关闭工作簿。"
                    ThisWorkbook.Close SaveChanges:=False
                End If
            Next i
            
            ' 首次运行完成后切换为静默模式
            isFirstRun = False
        End If
        
        ' 设置下一次检查时间（这里设为1分钟，可自行调整）
        Application.OnTime Now + TimeValue("00:01:00"), "ThisWorkbook.CheckExpiryAndAuth"
    Else
        ' 当前试用过期，切换到下一个阶段
        currentTrial = currentTrial + 1
        
        ' 检查是否还有可用试用
        If currentTrial > trials Then
            MsgBox "所有试用均已过期，即将关闭工作簿。"
            ThisWorkbook.Close SaveChanges:=False
        Else
            ' 提示用户输入新密码，并重新触发弹窗流程
            MsgBox "第 " & currentTrial - 1 & " 次试用已过期，请输入新密码继续。"
            isFirstRun = True
            CheckExpiryAndAuth
        End If
    End If
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ' 关闭工作簿时取消定时任务，避免残留报错
    On Error Resume Next
    Application.OnTime Now + TimeValue("00:01:00"), "ThisWorkbook.CheckExpiryAndAuth", Schedule:=False
    On Error GoTo 0
End Sub

关键改进说明 #

• 持续监控：通过Application.OnTime定时调用检查函数，间隔可自行调整（比如改成"00:00:30"就是30秒检查一次）。
• 静默控制：用isFirstRun变量标记是否为首次运行，仅启动时显示密码输入和剩余时间弹窗，后续检查完全静默。
• 过期自动切换：当前试用过期后自动切换到下一个密码组，强制要求输入新密码。
• 任务清理：在Workbook_BeforeClose中取消定时任务，防止Excel关闭后仍触发任务导致报错。

注意事项 #

• 保存工作簿为启用宏的工作簿（.xlsm），否则代码无法运行。
• 过期时间不需要转成字符串再转回日期，直接用DateSerial + TimeSerial生成日期类型即可，避免类型转换错误。
• 调整检查间隔时，不要设得太频繁（比如小于10秒），否则会影响Excel运行流畅度。

内容的提问来源于stack exchange，提问作者Joshua Kilian