如何创建在所有应用程序顶部弹出定时 Excel 消息，以通知用户他们已达到该 Excel 文件中的使用时间限制

Question

大约有二十名团队成员，轮流打开和编辑 Excel 文件。问题是，很多时候用户忘记长时间打开文件，这会阻止其他人访问并进行更新。希望在所述 Excel 文件处于不活动状态 5 分钟后，在所有打开的应用程序上方弹出一个“仅确定”消息框。还希望它冻结其他应用程序的使用，直到通过单击“确定”清除弹出窗口。另外，单击“确定”后，如果再有 5 分钟不活动，我希望再次出现相同的消息框。还希望仅当文件以所有者身份打开时才显示此消息。如果以只读方式打开，则不应出现弹出窗口。希望这个弹出提醒可以立即释放文件进行更新。

**更新： 下面是我最终使用的对我有用的代码。每当出现“不活动”时，它就会开始 8 分钟倒计时。如果仅单击某个单元格一次且未对其进行编辑，则倒计时会继续，但如果双击某个单元格或实际正在编辑该单元格，则倒计时不会运行。退出编辑后，倒计时从开始处开始。在设置的倒计时结束后，将显示一个弹出窗口，通知已经有 8 分钟处于不活动状态，并且他们有 300 秒的时间来关闭文件，否则文件将自动关闭而不保存，但会保存其他软件的副本以供参考。当文件自动关闭时，会出现辅助弹出窗口，通知文件已关闭但未保存，但副本已保存在指定位置。此后，此方法一直运行得非常完美，即使没有完全解决，也极大地解决了允许 20 个用户访问同一文件进行每日重复编辑的延迟问题。

下面代码的第一部分位于模块 1 下，下面代码的第二部分是表单代码。

第一部分 VVVVVVVVVVVVVVVVVVVVVVVVV

选项私有模块 选项显式

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

Const sPROCEDURE_NAME As String = "ShowForm_Countdown"

私人 dteCloseTime 作为日期

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

公共子定时器_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

结束子

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

公共子定时器_Stop()

On Error Resume Next

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

结束子

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

私有子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

结束子

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

私有子 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

结束子

第二部分 VVVVVVVVVVVVVVVVV

选项显式

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

私有 mbSaveWorkbook 作为布尔值 私有 mbCloseForm 作为布尔值

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

公共子StartCountdown()

Call ShowRemainingTime

结束子

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

公共属性获取 SaveWorkbook() 作为布尔值

SaveWorkbook = mbSaveWorkbook

结束财产

私有子lblMessage_Click()

结束子

私有子lblTimeOut_Click()

结束子

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

私有子用户表单_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

结束子

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

私人子btnCancel_Click()

mbSaveWorkbook = False
mbCloseForm = True

结束子

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

私有子UserForm_QueryClose（取消为整数，CloseMode为整数）

If CloseMode <> 1 Then

    Call btnCancel_Click
    Cancel = True

End If

结束子

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

私人子秀剩余时间()

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

结束子

Answer 1

几年前我做了类似的事情，但它非常简单，因为您似乎在显示消息时遇到问题，并将发布我在 Excel 2013 上测试的代码

将此粘贴到ThisWorkbook：

计时器在

Workbook_Open

事件中启动，此代码测试3秒并显示MsgBox

Private Sub Workbook_Open()
    If Not ThisWorkbook.ReadOnly Then
        ' Check for owner here
        Application.OnTime Now + TimeSerial(0, 0, 3), "module.FileTimeout"
    End If
End Sub

将其粘贴到模块中：

超时功能使用

AppActivate

激活Excel应用程序并在vbModal中显示MsgBox，因此它将显示在所有打开的应用程序的顶部（理论上）

Public Sub FileTimeout()
    AppActivate "Microsoft excel"
    MsgBox "Hey! Time has passed, close this file so others can open it!", vbInformation + vbOKOnly + vbSystemModal, "Excel timeout"
End Sub

就像我说的，我在 Excel 2013 中测试了这段代码并且它有效，如果我最小化所有窗口，它会显示在顶部的 MsgBox，如果我在其他应用程序中执行其他操作，它也会在顶部显示 MsgBox

如果 MsgBox 由于某种原因没有在前台显示，或者您只是想使用 UserForm 显示自定义消息，您可以检查 此答案 将表单置于顶部