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
Related
Background infromation:
This workbook is on shared point and I'm trying to run a Marco in Desktop app.
The objective on the marco is to close the workbook automatically after 10 mins. I want to ensure that users do not keep the workbook open without using it.
However, when I run the below code, I get an error message
"Cannot run the marco "https://wfp-mysharepoint.com............" This Macro may not be available in this workbook or marcos maybe disabled.
The code is as follows:
Private Sub Workbook_Open()
Picktime
End Sub
Sub Picktime()
savetime = Hour(Now) & ":" & Minute(Now) + 1 & ":" & Second(Now)
Application.OnTime savetime, "Please_close"
End Sub
Sub Please_close()
ThisWorkbook.Close (True)
End Sub
The procedure Workbook_Open is an event (that runs automatically) on opening of the workbook and therefore has to be in the scope of the workbook ThisWorkbook. Other events that are worksheet related are located in the scope of their worksheet.
All other code should go into a normal module. Especially code that needs to be found by Application.OnTime can only be located in a normal module.
So in ThisWorkbook:
Private Sub Workbook_Open()
Picktime
End Sub
In a normal module:
Public Sub Picktime()
Dim SaveTime As Variant
SaveTime = Now() + TimeValue("00:01:00")
Application.OnTime EarliestTime:=SaveTime, Procedure:="Please_close"
End Sub
Public Sub Please_close()
ThisWorkbook.Close SaveChanges:=True
End Sub
Note that it is easer to add one minute to Now() by using Now() + TimeValue("00:01:00")
I have a log of incoming / outgoing test samples which I've added code to kick users out if no worksheet change is detected for more than 5 minutes (https://excelribbon.tips.net/T008192_Forcing_a_Workbook_to_Close_after_Inactivity.html). In order to make sure users have macros enabled, I have a worksheet called "Splash Screen" which is the only worksheet visible when the workbook is first opened (all other worksheets are set to xlVeryHidden).
The code I have to hide/unhide worksheets looks simple and works perfectly if the workbook is closed manually, but not if forced to close via the timeout. This is called near the end of the Workbook_BeforeClose procedure:
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case Is = "Splash Screen"
ws.Visible = xlSheetVisible
Case Else
ws.Visible = xlSheetVeryHidden
End Select
Next
Application.ScreenUpdating = True
After this code block has run, there is no change to the visibility of the worksheets. Everything which was hidden is still hidden, everything that was visible is still visible, everything that was veryhidden is still veryhidden.
The worksheets are locked, but I've tried unlocking them before hiding them and that doesn't help. I've ensured events are enabled, screenupdating is true, errors are not set to "Resume Next", but none of it seems to help. Any suggestions?
Edited to add more code:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Checks for missing data in rows to be locked - if missing, user is prompted to enter
'User can optionally cancel closing the document to enter missing data
Call DataMissing(Cancel) 'If data missing and user wishes to enter, Cancel = True
If Cancel Then Exit Sub 'If Cancel = True, exit without further action
'Locks rows which were changed and Logs changes (if any were made)
Call LockRows
Call EmailPM("Delivered")
Call Internal_LockRows
If Not Not LoggedRows Then
Call LogChanges
Call EmailPM("Edited")
End If
If Not Not Internal_LoggedRows Then
Call Internal_LogChanges
End If
Call EmailPM("Internal")
'If changes have been made to live samples, updates lab manager
If Not Not LiveRows Then Call EmailPM("Live")
If Not Not Internal_LiveRows Then Call EmailPM("Internal_Live")
'Clears all filters on all sheets
Dim ws As Worksheet
On Error Resume Next
For Each ws In ThisWorkbook.Worksheets
ws.AutoFilter.ShowAllData
Next ws
On Error GoTo 0
'Selects MainLab sheet before closing
MainLab.Select
'Ensures TimeStop and RowID will fire on worksheet change
Application.EnableEvents = True
Call TimeStop
'Hides sheets (only unhides if macros are enabled)
Call HideSheets
'Stores who closed the file to log
LogToFile (ThisWorkbook.Name & "; " & OpenState & "; closed by; " & Environ("Username") & "; " & Format(Now, "yyyy-mm-dd hh:mm:ss"))
End Sub
Sub TimeSetting()
'Sets CloseTime to a set time in the future, then runs SavedAndClose
CloseTime = Now + TimeValue("00:00:30") 'Timeout after 5 mins of inactivity
On Error Resume Next
Application.OnTime earliesttime:=CloseTime, procedure:="SavedAndClose", Schedule:=True
On Error GoTo 0
End Sub
Sub TimeStop()
'A sub to stop the timer ticking down
On Error Resume Next
Application.OnTime earliesttime:=CloseTime, procedure:="SavedAndClose", Schedule:=False
On Error GoTo 0
End Sub
Sub SavedAndClose()
'Closes the workbook and saves when called
Application.CutCopyMode = False 'Empties the clipboard to avoid the potential "keep the clipboard" alert
LogToFile (ThisWorkbook.Name & "; " & OpenState & "; auto-closed; " & Environ("Username") & "; " & Format(Now, "yyyy-mm-dd hh:mm:ss"))
ThisWorkbook.Close savechanges:=True
End Sub
The main reason this does not work is ThisWorkbook.saved = True. Essentially this is saying I've already saved so don't bother prompting me to save when I close. Problem is you haven't saved at the time you are calling close.
Here is a basic example of the setup. You want to: 1. Hide the sheets, 2. Save the document, 3. Close.
Sub HideSheets()
' Insert your hide sheet code here
Sheet2.Visible = xlSheetHidden ' Test line to hide one sheet
ThisWorkbook.Save
End Sub
Sub ShutDown()
Call HideSheets
ThisWorkbook.Close
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'This doesn't do much on the automated close, because you've saved already.
Call HideSheets
End Sub
The Workbook.BeforeClose event triggers when the workbook is about to close but before the saving message prompt which allows cancelling it.
How can I detect when the workbook is already closing past the point where it can be cancelled without removing nor replacing the saving message with a custom one?
One workaround I have found online is to use the event together with the Workbook.Deactivate event which looks like this:
Code in the workbook:
Private Sub Workbook_BeforeClose(ByRef Cancel As Boolean)
closing_event = True
check_time = VBA.Now + VBA.TimeSerial(Hour:=0, Minute:=0, Second:=1)
Excel.Application.OnTime EarliestTime:=check_time, Procedure:="disable_closing_event"
End Sub
Private Sub Workbook_Deactivate()
If closing_event Then
VBA.MsgBox Prompt:="Closing event."
Excel.Application.OnTime EarliestTime:=check_time, Procedure:="disable_closing_event", Schedule:=False
End If
End Sub
Code in a module:
Public closing_event As Boolean
Public check_time As Date
Public Sub disable_closing_event()
closing_event = False
End Sub
One very specific edge case where it triggers incorrectly is if you click to close the workbook and in less than one second close the saving message (press Esc to do it fast enough) and change to another workbook (Alt + Tab) it triggers the Deactivate event with the closing_event condition variable still set to True because disable_closing_event has still not set it to False (scheduled by Application.OnTime for when one second goes by).
I would like to find a solution that isn't so much of a workaround and that works correctly against that edge case.
Edit:
The accepted answer has the best solution in my opinion out of all the current answers. I have modified it for my needs and preference to the following code in the workbook:
Private WorkbookClosing As Boolean
Private Sub Workbook_BeforeClose(Cancel As Boolean)
WorkbookClosing = True
End Sub
Private Sub Workbook_Deactivate()
If WorkbookClosing And ThisWorkbook.Name = ActiveWindow.Caption Then
Workbook_Closing
Else
WorkbookClosing = False
End If
End Sub
Private Sub Workbook_Closing()
MsgBox "Workbook_Closing event."
End Sub
This is an evolution of my 1st Answer - it detects the edge case problem by comparing the ActiveWindow.Caption against ThisWorkbook.Name so it can detect that issue and deal with it. It's not the most elegant solution but I believe it works.
All Code in the Workbook most of it in DeActivate
Public ByeBye As String
Private Sub Workbook_BeforeClose(Cancel As Boolean)
ByeBye = "B4C"
End Sub
Private Sub Workbook_Deactivate()
If ByeBye = "B4C" Then
If ActiveWindow.Caption = ThisWorkbook.Name Then
If ThisWorkbook.Saved Then
MsgBox "No problem - Closing after Saving"
Else
MsgBox "No problem - Closing without Saving"
End If
Else
If ThisWorkbook.Saved Then
MsgBox "No problem - New Workbook Activation"
Else
MsgBox "Oops Try Again You Cannot Activate '" & ActiveWindow.Caption & "' until '" & ThisWorkbook.Name & "' has completed processing & IT HAS NOW COMPLETED", vbOKOnly, "Hiding"
ThisWorkbook.Activate
End If
End If
Else
MsgBox "No problem - Just Hiding"
End If
ByeBye = "Done"
End Sub
Private Sub Workbook_Open()
ByeBye = "OPENED"
End Sub
In response to comment about saving I tested this for 7 possible combinations as follows
1) Closing without Edits - No Saving Involved ... MsgBox Prompted with ... No problem - Closing after Saving
2) Not closing - Just Switch Workbook - Whether Edited or Not ... MsgBox Prompted with ... No problem - Just Hiding
3) Not closing - Switch Workbook - After Edit & Cancel ... MsgBox Prompted with ... Oops Try Again …
4) Closing and saving ... MsgBox Prompted with ... No problem - Closing after Saving
5) Closing and Saving after a prior Cancel ... MsgBox Prompted with ... No problem - Closing after Saving
6) Closing but Not Saving ... MsgBox Prompted with ... No problem - Closing without Saving
7) Closing but not Saving after a prior Cancel ... MsgBox Prompted with ... No problem - Closing without Saving
I think trying to cancel the close event is the wrong approach for what you are trying to do. A better approach would be to have a function that is only called when the workbook is actually closing.
Thank you for the comments regarding OnTime not being called while the dialog is open as that pointed me in the right direction. What we need to test is the time between the workbook deactivation and the closing of either the workbook itself or the save dialog. Using the Excel.Application.OnTime function to set this close time means this is possible as it can be delayed until the save dialogue has closed.
Once we have this time, a simple comparison to the deactivation time allows us to decide whether to call the exit function or not.
I initially ran into issues with the workbook reopening to run the .OnTime procedure, so an artificial delay needs to be added into the Deactivation function so the workbook hasn't closed until the close time has been set. Using the code from here - Delay Macro to allow events to finish we can accomplish this.
In ThisWorkbook
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Excel.Application.OnTime EarliestTime:=Now, Procedure:="SetCloseTime"
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Timer < CloseTime + 0.2 Then Call CloseProcedure
End Sub
Private Sub Workbook_Deactivate()
Delay (0.3)
If Timer < CloseTime + 0.4 Then Call CloseProcedure
End Sub
In a module
Option Explicit
Public CloseTime As Single
Function SetCloseTime()
CloseTime = Timer
End Function
Function Delay(Seconds As Single)
Dim StopTime As Single: StopTime = Timer + Seconds
Do While Timer < StopTime
DoEvents
Loop
End Function
Function CloseProcedure()
MsgBox "Excel is closing"
End Function
The .OnTime seems to run within one second cycles which dictates the length of the delay and the time difference test has a little leeway added with an additional 1/10th of a second (which I found necessary). These timings could potentially need slight tweaking but have so far worked for me with the different scenarios when closing the workbook.
In order to get around your edge case, you need to handle the case where the workbook is deactivated within 1 second of closing it, but only when the save prompt was displayed.
To check if less than 1 second has elapsed, use a high resolution timer to store the time in the Workbook_BeforeClose event, and then compare against it in the Workbook_Deactivate event. Assuming that clsTimer is a suitable high res timer, your code should now be:
Private MyTimer As clsTimer
Private StartTime As Currency
Private Sub Workbook_BeforeClose(ByRef Cancel As Boolean)
closing_event = True
Set MyTimer = New clsTimer
StartTime = MyTimer.MicroTimer
check_time = VBA.Now + VBA.TimeSerial(Hour:=0, Minute:=0, Second:=1)
Excel.Application.OnTime EarliestTime:=check_time, Procedure:="disable_closing_event"
End Sub
Private Sub Workbook_Deactivate()
If closing_event Then
If Not ThisWorkbook.Saved Then
'The Save prompt must have been displayed, and the user clicked No or Cancel or pressed Escape
If MyTimer.MicroTimer - StartTime < 1 Then
'The user must have pressed Escape and Alt-Tabbed
closing_event = False
Else
'Your Windows API calls here
End If
Else
'The workbook was saved before the close event, so the Save prompt was not displayed
'Your Windows API calls here
End If
Excel.Application.OnTime EarliestTime:=check_time, Procedure:="disable_closing_event", Schedule:=False
End If
Set MyTimer = Nothing
End Sub
The class module for clsTimer looks like this:
Private Declare PtrSafe Function getFrequency Lib "kernel32" _
Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare PtrSafe Function getTickCount Lib "kernel32" _
Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long
Public Function MicroTimer() As Currency
' Returns seconds.
Dim cyTicks1 As Currency
Static cyFrequency As Currency
MicroTimer = 0
' Get frequency.
If cyFrequency = 0 Then getFrequency cyFrequency
' Get ticks.
getTickCount cyTicks1
' Seconds
If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency
End Function
This post could be helpful https://www.dummies.com/software/microsoft-office/excel/an-excel-macro-to-save-a-workbook-before-closing/
I found code below from the book Excel 2016 Power Programming with VBA, by Michael Alexander
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim msg As String, ans as integer
If Me.Saved = False Then
msg = "Do you want to save?"
ans = MsgBox(msg, vbquestion+vbyesnocancel)
Select Case ans
Case vbYes: Me.Save
Case vbCancel: Cancel = True
End Select
End If
Call mySub
Me.Saved = True
End Sub
I think deactivate is the best way to capture this.
Beforeclose might occur earlier than Save event if the document was not saved. So Excel might prompt to save before closure.
But Deactivate is the final event before closure (after save). So this can be used.
had a similar problem and tried to run some macro before closing but it is dependad whether user wants to save workbook or not.
My solution was the code below, though there is a problem, that window of excel always stays open.
Public ClosedByProgram As Boolean
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not ClosedByProgram Then
Cancel = True
Dim Ans As String
Ans = MsgBox("Want to save your changes to '" & ThisWorkbook.Name & "'?", vbYesNoCancel, "Microsoft Excel")
If Ans = vbNo Then
ClosedByProgram = True
ThisWorkbook.Close
ElseIf Ans = vbYes Then
Dim STR As String: STR = "'" & ThisWorkbook.Name & "'!" & "mod16_Versioning.IsSuitableForSaving"
Dim isForSaving As Boolean: isForSaving = Application.Run(STR, SaveAsUI)
If isForSaving Then
Dim STRToRun As String
STRToRun = "'" & ThisWorkbook.Name & "'!" & "mod02_Events.BeforeSave"
Application.Run STRToRun, SaveAsUI
Dim STRVersions As String: STRVersions = "'" & ThisWorkbook.Name & "'!" & "mod16_Versioning.MakeVersion"
Dim blankCheck As Boolean: blankCheck = Application.Run(STRVersions, SaveAsUI)
ClosedByProgram = True
ThisWorkbook.Close
End If
End If
Else
ThisWorkbook.Saved = True
Application.Quit
End If
End Sub
This seems to work
Code in the WorkBook
Public ByeBye As String
Private Sub Workbook_BeforeClose(Cancel As Boolean)
ByeBye = "BB # " & Now()
End Sub
Private Sub Workbook_Deactivate()
If Left(ByeBye, 2) = "BB" Then
ByeBye="Done"
MsgBox "Closing"
Else
ByeBye="Done"
MsgBox "DeActivating BUT NOT Closing"
End If
End Sub
Private Sub Workbook_Open()
ByeBye = "OP # " & Now()
End Sub
Just uses a public variable ByeBye
You must initialise it in WorkBook.Open
You must Set it in WorkBook.BeforeClose
and can test it in WorkBook.DeActivate
In case it is needed for this to work even after a VBA crash - and loss of ByeBye value I'm resetting it in the Workbook_SheetChange and in WorkBook_SheetSelectionChange
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
ByeBye = "SC # " & Now()
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
ByeBye = "SSC # " & Now()
End Sub
The above addendum is really only needed if you were going to use the string default of "" for the tested value - but I'm using "BB # " & Now() so this is not really needed
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'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