Question

我正在尝试创建一个可以在5分钟内自动关闭工作簿的宏，并且会在4分30秒内弹出提示消息。如果用户没有单击确定按钮，我希望消息框在10秒内自动关闭。我陷入了消息框无法在10秒内关闭的程度。我的大多数代码都是从互联网上复制的。以下是我的代码：

在工作簿页面中：

Private Sub workbook_open()
    Call settimer
End Sub

Private Sub workbook_beforeclose(cancel As Boolean)
    Call stoptimer
End Sub

Private Sub workbook_sheetcalculate(ByVal sh As Object)
    Call stoptimer
    Call settimer
End Sub

Private Sub workbook_sheetselectionchange(ByVal sh As Object, _
ByVal target As Excel.Range)

    Call stoptimer
    Call settimer

End Sub

在模块中

Dim downtime As Date

Sub settimer()

    downtime = Now + TimeValue("00:01:00")

    alerttime = downtime - TimeValue("00:00:50")

    Application.OnTime Earliesttime:=alerttime, _
    procedure:="alertuser", schedule:=True

    Application.OnTime Earliesttime:=Downtime, _
    procedure:="shutdown", schedule:=True

End Sub

Sub stoptimer()

    On Error Resume Next

    Application.OnTime Earliesttime:=downtime, _
    procedure:="shutdown", schedule:=False

End Sub

Sub shutdown()

    Application.DisplayAlerts = True

    With ThisWorkbook

        .Save = True

        .Close

    End With

End Sub

Sub alertuser()

    Dim wsshell

    Dim intText As Integer

    Set wsshell = CreateObject("WScript.Shell")

    intText = wsshell.Popup("log sheet will be closed in 30 seconds if there are no more inputs", 10, "reminder")

    Set wsshell = Nothing

End Sub

Answer 1

您需要完全限定您的程序名称。它没有找到有问题的程序。您还有一个拼写错误，并且缺少全局变量alerttime。试试这个：

Public downtime As Date
Public alerttime As Date

Private Sub workbook_open()
    Call settimer
End Sub

Private Sub workbook_beforeclose(cancel As Boolean)
    Call stoptimer
End Sub

Private Sub workbook_sheetcalculate(ByVal sh As Object)
    Call stoptimer
    Call settimer
End Sub

Private Sub workbook_sheetselectionchange(ByVal sh As Object, _
ByVal target As Excel.Range)

    Call stoptimer
    Call settimer

End Sub    

Sub settimer()

    downtime = Now + TimeValue("00:01:00")

    alerttime = downtime - TimeValue("00:00:50")

    'fully qualify your procedure name here and the procedure will run
    Application.OnTime Earliesttime:=alerttime, _
    procedure:="WorkbookName.xlsm!ThisWorkbook.alertuser", schedule:=True

    'and here... also typo was here in downtime
    Application.OnTime Earliesttime:=downtime, _
    procedure:="WorkbookName.xlsm!ThisWorkbook.shutdown", schedule:=True

End Sub

Sub stoptimer()

    On Error Resume Next

    Application.OnTime Earliesttime:=downtime, _
    procedure:="shutdown", schedule:=False

End Sub

Sub shutdown()

    Application.DisplayAlerts = True

    With ThisWorkbook

        .Save = True

        .Close

    End With

End Sub

Sub alertuser()

    Dim wsshell

    Dim intText As Integer

    Set wsshell = CreateObject("WScript.Shell")

    intText = wsshell.Popup("log sheet will be closed in 30 seconds if there are no more inputs", 10, "reminder")

    Set wsshell = Nothing

End Sub

Answer 2

您可以使用userform（您在VBA编辑器中Insert进入项目），如下所示：

在属性窗口中，我将表单名称更改为formReminder，以便在其他模块中更容易引用。然后，在userform的代码窗口中，我输入：

Private Running As Boolean

Private Sub CommandButton1_Click()
    Running = False
End Sub

Private Sub UserForm_Activate()
    Dim start As Single
    start = Timer
    Running = True
    Do While Running And Timer < start + 10
        DoEvents
    Loop
    Unload Me
End Sub

Private Sub UserForm_Click()
    Running = False
End Sub

当您在代码中的任何其他位置运行formReminder.Show行时（例如 - 代替您创建弹出窗口的位置），表单将显示并显示10秒（如果您单击任何位置，则显示更少）然后消失。

显示它时会显示如下：

Answer 3

谢谢，John Coleman您的回答。它让我找到了我想要的解决方案很长一段时间。我接受了您的代码并将其转换为通用函数，该函数接受消息的参数和等待的秒数。

Sub MsgBoxTimerTest()
' Test the Message box with a timer form
Dim vReturn As Variant
vReturn = MsgBoxTimerCall("MessageBox that Dissappears after n Seconds", "Hello World!", 3)
End Sub
' **************************************************************************

Function MsgBoxTimerCall(strCaption As String, strMessage As String, intSeconds As Integer)
' Show a messagebox for a while
' https://stackoverflow.com/questions/37281840/automatic-close-excel-workbook-with-a-pop-up-message
' 2016-06-21
TimerSeconds = intSeconds
msgBoxTimerForm.Caption = strCaption
msgBoxTimerForm.TextBox1.Value = strMessage
msgBoxTimerForm.Show
End Function
' **************************************************************************

' **************************************************************************
Insert this code in the form
' **************************************************************************
Private Running As Boolean

Private Sub CommandButton1_Click()
    MsgBox "Yo!"
    Running = False
End Sub

Private Sub UserForm_Activate()
    Dim start As Single
    start = Timer
    Running = True
    Do While Running And Timer < start + TimerSeconds
        DoEvents
    Loop
    Unload Me
End Sub

Private Sub UserForm_Click()
    Running = False
End Sub

自动关闭excel工作簿，弹出消息

3 个答案: