如何实现Excel定时置顶弹窗提醒，解决共享文件占用问题

问题背景 #

• 团队约20人轮流编辑共享Excel文件，常出现用户忘记关闭文件导致他人无法访问更新的问题
• 初始需求：
  1. 仅在所有者模式打开文件时，无操作5分钟后弹出仅含“确定”的置顶弹窗，冻结其他应用直至点击确定
  2. 点击确定后若再次无操作5分钟，弹窗重复出现

最终实现方案 #

最终采用VBA代码实现以下逻辑，已稳定运行一年，大幅解决多人访问延迟问题：

• 8分钟无操作后启动倒计时
• 编辑单元格时暂停倒计时，退出编辑后重新计时
• 倒计时结束后弹出提示，告知用户300秒后文件将自动关闭并备份
• 点击确定则重启8分钟倒计时；超时后文件自动关闭并在指定路径备份

VBA代码实现 #

模块1代码 #

Option Private Module
Option Explicit

'===============================================================

Const sPROCEDURE_NAME   As String = "ShowForm_Countdown"

Private dteCloseTime    As Date

'======================================================

Public Sub Timer_Start()

Const sINTERVAL As String = "00:08:00"

dteCloseTime = Now + TimeValue(sINTERVAL)

On Error Resume Next

Application.OnTime EarliestTime:=dteCloseTime, _
                   Procedure:=sPROCEDURE_NAME, Schedule:=True

End Sub

'=====================================================

Public Sub Timer_Stop()

On Error Resume Next

Application.OnTime EarliestTime:=dteCloseTime, _
                   Procedure:=sPROCEDURE_NAME, Schedule:=False

End Sub

'====================================================

Private Sub ShowForm_Countdown()

Dim frmCountdown As F01_Countdown

Set frmCountdown = New F01_Countdown

    With frmCountdown
    
    
        If ThisWorkbook.ReadOnly = False Then
    
            .Show vbModeless
            .StartCountdown

            If .SaveWorkbook = True Then
                  Call SaveAsAndClose
            Else: Call Timer_Start
            End If
        
        End If

    End With

    Unload frmCountdown

Set frmCountdown = Nothing

End Sub

'=====================================================

Private Sub SaveAsAndClose()

Const filelocation      As String = "X:\APG\Shortlist Backups"
Const sTIMEOUT_FILE     As String = "Shortlist Timeout_Dont Delete.xlsm"

Dim sTimeOutMessageFile As String
Dim sFileNameArray()    As String
Dim sThisFileName       As String
Dim sBaseFileName       As String
Dim sNewFileName        As String
Dim sFolderPath1        As String
Dim sFolderPath2        As String
Dim sTimeStamp          As String
Dim sFullName1          As String
Dim sFullName2          As String

sTimeOutMessageFile = filelocation & "\" & sTIMEOUT_FILE

sThisFileName = ThisWorkbook.Name
sFileNameArray = Split(sThisFileName, ".")
sBaseFileName = sFileNameArray(0)

sFolderPath1 = Environ("UserProfile") & "\Documents\Shortlist Backups"
sFolderPath2 = filelocation & "\Shortlist Backups"


If Len(Dir(sFolderPath1, vbDirectory)) = 0 Then
    MkDir Path:=sFolderPath1
         
End If

If Len(Dir(sFolderPath2, vbDirectory)) = 0 Then
    MkDir Path:=sFolderPath2
         
End If

sTimeStamp = Format(Now, "hmm")

sNewFileName = sBaseFileName & "_AutoSave_" & sTimeStamp & ".xlsx"

sFullName1 = sFolderPath1 & "\" & sNewFileName
sFullName2 = sFolderPath2 & "\" & sNewFileName

Application.DisplayAlerts = False

    ThisWorkbook.CheckCompatibility = False
    ThisWorkbook.SaveAs Filename:=sFullName1, FileFormat:=51
    ThisWorkbook.SaveAs Filename:=sFullName2, FileFormat:=51

Application.DisplayAlerts = True

Workbooks.Open Filename:=sTimeOutMessageFile

ThisWorkbook.Close

End Sub

表单代码（F01_Countdown） #

Option Explicit

'==================================================

Private mbSaveWorkbook  As Boolean
Private mbCloseForm     As Boolean

'==================================================

Public Sub StartCountdown()

Call ShowRemainingTime

End Sub

'==================================================

Public Property Get SaveWorkbook() As Boolean

SaveWorkbook = mbSaveWorkbook

End Property

Private Sub lblMessage_Click()

End Sub

Private Sub lblTimeOut_Click()

End Sub

'====================================================

Private Sub UserForm_Initialize()

Dim sCaption As String

sCaption = "If file is not closed by end of countdown below the file will " & _
           "close automatically without saving and a backup of your edits " & _
           "will be saved at:" & _
            vbLf & vbLf & _
            Environ("UserProfile") & "\Documents\Shortlist Backups\"

Me.lblMessage.Caption = sCaption

Me.btnCancel.SetFocus

mbSaveWorkbook = True
mbCloseForm = False

End Sub

'===================================================

Private Sub btnCancel_Click()

mbSaveWorkbook = False
mbCloseForm = True

End Sub

'================================================

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

If CloseMode <> 1 Then

    Call btnCancel_Click
    Cancel = True

End If

End Sub

'==================================================

Private Sub ShowRemainingTime()

Const iTOTAL_SECONDS    As Integer = 300
Const iINTERVAL         As Integer = 1

Dim iSecondsElapsed     As Integer
Dim dteStartTime        As Date

Me.lblTimeOut.Caption = "in " & iTOTAL_SECONDS & " seconds"

dteStartTime = Now()
iSecondsElapsed = 0

Do

    iSecondsElapsed = iSecondsElapsed + iINTERVAL
    DoEvents

    Do
        DoEvents

    Loop While dteStartTime + (TimeValue("00:00:01") * iSecondsElapsed) >= Now() And _
               mbCloseForm = False

    Me.lblTimeOut.Caption = "in " & (iTOTAL_SECONDS - iSecondsElapsed) & " seconds"

Loop While iSecondsElapsed < iTOTAL_SECONDS And _
           mbCloseForm = False

mbCloseForm = True

End Sub

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