I'm using the Application.Ontime command to automatically close a spreadsheet after a period of inactivity (10 minutes).
The following code seems to work in general, however, it appears that if you manually close the sheet yourself, the workbook still seems to be active in the background and at the last designated 'endtime' will open itself so that it can close itself.
This is also evident in the VBA code window as after the CloseWB macro runs and the excel workbook appears to be closed, it is still listed in the VBA project explorer window.
Sub RunTime()
Static EndTime
If Not EndTime = "" Then ActiveWorkbook.Application.OnTime EndTime, "CloseWB", , False
EndTime = Now + TimeValue("00:10:00")
ActiveWorkbook.Application.OnTime EndTime, "CloseWB", , True
End Sub
Sub CloseWB()
Application.DisplayAlerts = False
With ThisWorkbook
.Save
.Close
End With
End Sub
I don't want to completely shutdown excel (application.quit) in case users have other workbooks open but need to try and stop the specific workbook running in the background.
Any ideas?
You need to stop the timer. Declare EndTime as a public variable, then turn the timer off in the Workbook_BeforeClose event.
Option Explicit
Public EndTime As Variant
Sub RunTime()
If Not EndTime = "" Then ActiveWorkbook.Application.OnTime EndTime, "CloseWB", , False
EndTime = Now + TimeValue("00:10:00")
ActiveWorkbook.Application.OnTime EndTime, "CloseWB", , True
End Sub
Sub CloseWB()
Application.DisplayAlerts = False
With ThisWorkbook
.Save
.Close
End With
End Sub
In the Workbook object:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnTime earliesttime:=EndTime, procedure:="CloseWB", schedule:=False
End Sub
Related
Something which we encounter on a daily basis at work is when a member of the team opens Excel Workbook from a network share to update the workbook and forget to save and close the file after he is finished.
The issue arise when the user locks his workstation and walks away from his desk leaving his co-workers unable to modify the shared excel workbook (read only).
P.S Locking your workstation before each time you leave your desk is something crucial for security reasons and I encourage the reader to adopt this good cyber hygiene habit.
How can I solve this issue once and for all?
One might argue that opening such documents in the cloud might solve the problem but this depends on the nature of the contents being stored in the document.
I had some initial parameters defined wrong and it's always better to do stuff like this at the Modules level.
For your ThisWorkbook section, only have this code:
Private Sub Workbook_Open()
Call TheTimerMac
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Call RestApplicationTimer
End Sub
Then in a standard Module insert the below code. The settings can be adjusted with the constants, which it looks like you understand (btw thanks for CDATE function -- shorter than TimeValeu)
I also inserted a couple audio warnings, partially just for my own entertainment. You look sharp enough that you can just nuke them if you don't like them.
'STANDARD MODULE CODE
'Constants
'Time settings
Const idleTimeLIMIT As String = "00:35:00" '<---- Edit this to whatever timer you want (hour:min:sec)
Const checkIntervalTime As String = "00:01:00" '<---- this can be executed frequently as it has low overhead
'Set this variable TRUE to confirm the macro is working with popup messages
Const conFirmRunning As Boolean = False
Dim LastCalculate As Date 'Make sure this is outside and above the other macros
Option Private Module
Public Sub TheTimerMac()
'message you can have displayed to make sure it's running
If conFirmRunning Then MsgBox "TheTimerMac is running."
'Schedules application to execute below macro at set time.
Application.OnTime Now + CDate(checkIntervalTime), "AnyBodyWorking"
End Sub
Private Sub AnyBodyWorking()
'OPTIONAL Warning messages to be spoken
Const TenMinuteWarning As String = "Your file will save and close in approximately 10 minutes"
Const FiveMinuteWarning As String = "Your file will save and close in approximately 5 minutes"
Const OneMinuteWarning As String = "This is the last warning. Your file will save and close in a little over a minute."
'message you can have displayed to make sure it's running
If conFirmRunning Then MsgBox "AnyBodyWorking Macro is running."
If LastCalculate = 0 Then
'Won't close application if lastCalc hasn't been set
Call RestApplicationTimer
ElseIf Now > LastCalculate Then
'if nothing has happened in the last idleTime interval... then it closes.
'close and lock it up!!
ThisWorkbook.Save
ThisWorkbook.Close
Exit Sub 'not even sure if this is needed, but probably good to be sure
''Optional spoken warnings
ElseIf DateDiff("S", Now, LastCalculate) < 60 Then
Application.Speech.Speak OneMinuteWarning
ElseIf DateDiff("S", Now, LastCalculate) < 300 Then
Application.Speech.Speak FiveMinuteWarning
ElseIf DateDiff("S", Now, LastCalculate) < 600 Then
Application.Speech.Speak TenMinuteWarnin
End If
Call TheTimerMac
End Sub
Sub RestApplicationTimer()
LastCalculate = Now + CDate(idleTimeLIMIT)
End Sub
Lastly, I think you could slightly improve the the locked function to be as follows and you could inculde it in your if statements.
Function IsLocked() As Boolean
IsLocked = _
GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
Environ$("computername") & "\root\cimv2"). _
ExecQuery("select * from Win32_Process where Name='logonui.exe'").Count > 0
End Function
Save the excel file as .xlsm to enable the storing of macros in the workbook itself.
Go to: Developer Tab -> Visual Basic
Double click: 'This Workbook', on the left hand pane
Paste the following VBA code:
Private Sub Workbook_Open()
Application.OnTime Now + TimeValue("00:01:00"), "Save1"
End Sub
Right Click VBAProject -> Insert -> Module
Paste the following VBA Code:
Sub Save1()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
If IsLocked(Environ$("computername")) > 0 Then
Workbooks("book1test.xlsm").Close SaveChanges:=True
End If
Application.OnTime Now + TimeValue("00:01:00"), "Save1"
End Sub
Function IsLocked(strComputer)
With GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
IsLocked = .ExecQuery("select * from Win32_Process where Name='logonui.exe'").Count '
End With
End Function
Save the Macro: Ctrl+s
This macro will be triggered every time you open the workbook, save your work every minute and only close the workbook if your screen/workstation is logged. You can remove the auto-save feature if you want.
Credits:
Check if computer is locked using VBscript
How to save Excel file every say minute?
#PGSystemTester this was the only way I could get it to work:
In ThisWorkbook:
Public idleTIME As Date '<---- Edit this to whatever timer you want (hour:min:sec)
Private Sub Workbook_Open()
idleTIME = CDate("00:10:00")
LastCalculate = Now + idleTIME
Check
End Sub
Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
LastCalculate = Now + idleTIME
End Sub
In module Option 1:
Public LastCalculate As Date
Const checkIntervalTime As String = "00:01:00"
Sub Check()
Call TheTimerMac
End Sub
Private Sub TheTimerMac()
Dim nextRunTime As Date
nextRunTime = Now + CDate(checkIntervalTime)
'Schedules application to execute below macro at set time.
Application.OnTime nextRunTime, "AnyBodyWorking"
End Sub
Private Sub AnyBodyWorking()
If Now > LastCalculate Then
'if nothing has happened in the last idleTime interval... then it closes.
'close and lock it up!!
ThisWorkbook.Save
ThisWorkbook.Close
Else
'executes the timerMacagain
Call TheTimerMac
End If
End Sub
module Option 2 (for locked screen):
Public LastCalculate As Date 'Make sure this is outside and above the other macros
Const checkIntervalTime As String = "00:00:30" '<---- this can be frequent as it has low overhead
Sub Check()
Call TheTimerMac
End Sub
Private Sub TheTimerMac()
Dim nextRunTime As Date
nextRunTime = Now + CDate(checkIntervalTime)
'Schedules application to execute below macro at set time.
Application.OnTime nextRunTime, "AnyBodyWorking"
End Sub
Private Sub AnyBodyWorking()
If Now > LastCalculate Or (IsLocked("FIBRE-X") > 0) Then
'if nothing has happened in the last interval idleTime OR Screen is Locked... then it closes.
'close and lock it up!!
ThisWorkbook.Save
ThisWorkbook.Close
Else
'executes the timerMacagain
Call TheTimerMac
End If
End Sub
Function IsLocked(strComputer)
With GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
IsLocked = .ExecQuery("select * from Win32_Process where Name='logonui.exe'").Count '
End With
End Function
Anything I can improve on this please?
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
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.
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
The macro runs with a button assigned to "CloseMe". It used to run for my needs but doesn't anymore (as I tried using this code in another workbook without success). Now it saves, closes, waits 10sec to reopen, but then closes right away.
Sub CloseMe()
Application.OnTime Now + TimeValue("00:00:10"), "OpenMe"
ThisWorkbook.Close True
End Sub
Sub OpenMe()
Application.OnTime Now + TimeValue("00:10:00"), "OpenMe"
ThisWorkbook.Close True
End Sub
I need the code to save, close, wait 10sec to reopen, stay open for 10min (to collect real time data), and then repeat this process (until I interrupt it manually to stop). Thanks
The code does what you are asking it to do: a. CloseMe schedules OpenMe for 10 seconds from now and closes the workbook, then b. Excel re-opens the workbook and invokes OpenMe, which schedules itself for 10 minutes from now, then immediately proceeds to close the workbook, and finally Excel resumes at b 10 minutes later, in a loop.
My understanding is that your code has to perform something either in OpenMe or CloseMe, so you do not want to just schedule a call and close the workbook. Additionally, to cycle, one sub needs to schedule the other. In broad terms, you could go along those lines:
Sub CloseMe()
'Here, do whatever (if anything) must be done just before saving the workbook.
'...
'Schedule the OpenMe execution in 10 seconds.
'I don't understand why you need to close the workbook, but that's not the question.
Application.OnTime Now + TimeValue("00:00:10"), "OpenMe"
ThisWorkbook.Close True
End Sub
Sub OpenMe()
'Here, do whatever (if anything) must be done just as the workbook opens.
'...
'Schedule the CloseMe execution in 10 minutes.
Application.OnTime Now + TimeValue("00:10:00"), "CloseMe"
End Sub
You are calling the OpenMe sub for both Open and Close subs.
If you want this to run automatically, where does close sub get called other than the command button?
#Excelosaurus we are very close. Thanks for explaining this logically on the different subs. Here is the full code. It works but my time stamps are doubling up when it is recording, closing, & re-opening. I am capturing some RTD and in order for the RTD to refresh you need to open and close the workbook. I tried inserting in ActiveWorkbook.ForceFullCalculation = True to avoid the extra open/close subs but the RTD did not recalculate using this so the only way was to run a open/close sub.
Dim NextTime As Double
Sub RecordData()
Dim Interval As Double
Dim cel As Range, Capture As Range
Application.StatusBar = "Recording Started"
Set Capture = Worksheets("Dashboard").Range("C5:K5") 'Capture this row of data
With Worksheets("Journal") 'Record the data on this worksheet
Set cel = .Range("A2") 'First timestamp goes here
Set cel = .Cells(.Rows.Count, cel.Column).End(xlUp).Offset(1, 0)
cel.Value = Now
cel.Offset(0, 1).Resize(1, Capture.Cells.Count).Value = Capture.Value
End With
NextTime = Now + TimeValue("00:01:00")
Application.OnTime NextTime, "RecordData"
End Sub
Sub StopRecordingData()
Application.StatusBar = "Recording Stopped"
On Error Resume Next
Application.OnTime NextTime, "OpenMe", , False
On Error GoTo 0
End Sub
Sub OpenMe()
Call RecordData
Application.OnTime Now + TimeValue("00:10:00"), "CloseMe"
End Sub
Sub CloseMe()
Application.OnTime Now + TimeValue("00:00:10"), "OpenMe"
ThisWorkbook.Close True
End Sub
I want to close my workbook if it's inactive for 1 minute. But before closing, I want to save a backup of it, but make no changes to the original. How can I incorporate this code:
ActiveWorkbook.SaveAs filename:=filename, FileFormat:=xlWorkbookNormal
into this procedure
Sub SetTimer()
Dim bookname
Dim filename
DownTime = Now + TimeValue("00:01:00")
bookname = ActiveWorkbook.Name
filename = "C:\myhome\backups\" & bookname
Application.OnTime EarliestTime:=DownTime, _
Procedure:="ShutDown", Schedule:=True
End Sub
If I insert it into the code, it asks me to save before the timer is done. I want it to ask after the time is done.
I think this is what you are after:
Public Sub SetTimer()
Dim DownTime As Date
DownTime = Now + TimeValue("00:01:00")
Application.OnTime EarliestTime:=DownTime, _
Procedure:="ShutDown", Schedule:=True
End Sub
Private Sub ShutDown()
' Be careful about using ActiveWorkbook vs ThisWorkbook vs getting a direct reference to the required workbook.
Dim bookname As String
bookname = ActiveWorkbook.Name
Dim filename As String
filename = "C:\myhome\backups\" & bookname
ActiveWorkbook.SaveAs filename:=filename, FileFormat:=xlWorkbookNormal
End Sub
You need to put the SaveAs into a separate method called "ShutDown". I assume that you put it at the end of the original method. The call to Application.OnTime() runs and schedules ShutDown() to be called later on then immediately continues to run the rest of the code in SetTimer().
Just put an event handler in for Workbook_BeforeClose. I'd personally check to see if it had been altered too so you don't get a bunch of needless backups:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
If Not Me.Saved Then
Me.SaveAs "C:\myhome\backups\" & Me.Name, xlWorkbookNormal
End If
Application.DisplayAlerts = True
End Sub
I have written a macro that runs at 15:30pm every workday when a workbook is first opened.
When the workbook is closed it tries to open itself the next time the macro is scheduled to run. I have tried to turn the scheduler to false and am getting an error. Code below.
Has anyone any ideas why this isn't working?
Private Sub Workbook_Open()
Application.OnTime TimeValue("15:30:00"), "MacroTimeTest"
End Sub
public dtime as date
Sub MacroTimeTest()
dtime = (Format(Application.Evaluate("workday(today(), 1)"), "DD/MM/YY") & " " & TimeValue("15:30:00"))
'other code has been deleted doesn't affect dtime variable
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'I have tried replacing false with 0 etc but it didn't make a difference
Application.OnTime earliesttime:=dtime, procedure:="MacroTimeTest", schedule:=False
End Sub
I think that you should keep a reference to the time so that you can cancel the action. You can only cancel an action if it hasn't already executed.
In ThisWorkbook enter the following to run the macro at 15:59 until the sheet is closed
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error GoTo CouldNotCancel
Application.OnTime dTime, "MacroTimeTest", , False
Debug.Print "Cancelled task to run at " & dTime
Debug.Print "Workbook close"
Exit Sub
CouldNotCancel:
Debug.Print "No task to cancel"
End Sub
Private Sub Workbook_Open()
Debug.Print "Workbook open"
dTime = TimeValue("15:59:00")
Debug.Print "Next run time " & dTime
Application.OnTime dTime, "MacroTimeTest"
End Sub
Then add your macro to a Module
Option Explicit
Public dTime As Date
Public Sub MacroTimeTest()
'schedule next run
dTime = TimeValue("15:59:00")
'schedule next run
Debug.Print "Scheduling next run at " & dTime
Application.OnTime dTime, "MacroTimeTest"
Debug.Print "Running macro"
End Sub
This way the same value of dTime will be used to cancel the scheduled task as was used to create it.
If no further task has been scheduled i.e. by an error in MacroTimeTest then the Workbook close event will handle the error.
To see the debug output look at the immediate window in the VBA Editor (Ctrl+G)