Application.OnTime 在其他工作簿打开时重新打开工作簿

Question

I have a timer that closes my workbook after 5 minutes. The issue is when i have another workbook open the workbook with the timer will reopen when i try to close it.

Earlier i had the countdown to "tick" every second but that messed up the view of comments making them blink for every countdown tick. When i had that I didn't see any issues with reopening of the workbook.

I have this in both my module and thisworkbook

Public gCount as Date

These two codes are in my module. The timer is displayed in a cell (Worksheets("kode").Range("H3")) and counts down every 10 seconds

Sub Timer()
gCount = Now + TimeValue("00:00:10")
Application.OnTime gCount, "ResetTime"
End Sub

Sub ResetTime()
Dim xRng As Range
If ThisWorkbook.Worksheets("kode").Range("H3") = "" Then GoTo Endsub
Set xRng = Application.ThisWorkbook.Worksheets("kode").Range("H3")
xRng.Value = xRng.Value - TimeSerial(0, 0, 10)
If xRng.Value <= 1.15740740740741E-05 Then
Call SavedAndClose
Exit Sub
End If
Call Timer

Endsub:

End Sub

This code is in ThisWorkbook

Private Sub Workbook_BeforeClose(Cancel As Boolean)

On Error Resume Next

gCount = Now + TimeValue("00:00:10")
Application.OnTime gCount, "ResetTime", Schedule:=False

ThisWorkbook.Worksheets("Interface").Select

'Hides all sheets but the interface sheet
Sheet2.Visible = False
Sheet3.Visible = False
Sheet6.Visible = False
Sheet7.Visible = False
Sheet8.Visible = False

End Sub

There too is a place where the cell Worksheets("kode").Range("H3") is set to 00:05:01 and a Workbook_SheetSelectionChange where it resets it to 00:05:01

The sheet closes when Worksheets("kode").Range("H3") is at 00:00:01

If i remove the "On Error Resume Next" the code makes a 1004 run-time error when i try to close the workbook.

Hope that someone can help me close my workbook

Best regards

Answer 1

If i remove the "On Error Resume Next" the code makes a 1004 run-time error when i try to close the workbook.

And that is why you should not put On Error Resume Next everywhere to silence errors instead of fixing them.

Application.OnTime can schedule the same procedure multiple times for different times of day. For this reason, it can only unschedule a previously scheduled entry when you provide the exact time for which it was scheduled - if you provide a time for which there is no scheduled entry, you will get a runtime error 1004.

Now + TimeValue("00:00:10") returns a different value each time you call it.

If you want to be able to cancel a previously set entry, store the time in a module-level variable and use that variable for both scheduling and unscheduling. Your module-level gCount variable would do, but:

• You have two of them ("I have this in both my module and thisworkbook")
• You overwrite the previously stored value with a useless new one right before calling Schedule:=False .

Make sure you only have one gCount , and only assign to it before scheduling a call, not before unscheduling it.

Answer 2

I found an answer to my own comment to GSergs answer:

I made a Msgbox with vbYesNoCancel options and canceled the OnTime event in the Yes and No answer and work around the generic "Save changes" prompt in excel. If Cancel is pressed the macro will cancel.

The "If xRng.Value <= 1.15740740740741E-05 Then" in the beginning insures that if the timer has run out it skips the MsgBox and just saves.

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Set xRng = Application.ThisWorkbook.Worksheets("kode").Range("H3")
If xRng.Value <= 1.15740740740741E-05 Then
Application.ScreenUpdating = False

ThisWorkbook.Worksheets("Interface").Select

'Hides all sheets but the interface sheet
Sheet2.Visible = False
Sheet3.Visible = False
Sheet6.Visible = False
Sheet7.Visible = False
Sheet8.Visible = False

Application.OnTime gCount, "ResetTime", Schedule:=False
If ThisWorkbook.Saved = False Then
    ThisWorkbook.Save
End If
Application.ScreenUpdating = True
GoTo Endsub
Else
End If


Dim intValue As Integer
intValue = MsgBox("Do you want to save changes?", 3, "Save changes?")

If intValue = 6 Then

Application.ScreenUpdating = False

ThisWorkbook.Worksheets("Interface").Select

'Hides all sheets but the interface sheet
Sheet2.Visible = False
Sheet3.Visible = False
Sheet6.Visible = False
Sheet7.Visible = False
Sheet8.Visible = False

Application.OnTime gCount, "ResetTime", Schedule:=False
If ThisWorkbook.Saved = False Then
    ThisWorkbook.Save
End If
Application.ScreenUpdating = True

ElseIf intValue = 7 Then

Application.ScreenUpdating = False

ThisWorkbook.Worksheets("Interface").Select

'Hides all sheets but the interface sheet
Sheet2.Visible = False
Sheet3.Visible = False
Sheet6.Visible = False
Sheet7.Visible = False
Sheet8.Visible = False

Application.OnTime gCount, "ResetTime", Schedule:=False
ThisWorkbook.Saved = True
Application.ScreenUpdating = True

Else
Cancel = True

End If
End Sub

Hope it can help someone with the same issue.

Best regars Søren