Good question. Imagine a scenario where you are in a workplace and need to open a shared server file that is used my several different people perhaps in different offices and update it. Isn't it completely frustrating when you get the "open read only" message and cant edit and save it. Not too bad if you know they are working on it, but if it's because they have gone home for the weekend leaving the file open on their machine that really can cause issues.
Well! fear not, with a little bit of code & the permission of your boss you can now prevent this by setting the file to close after excel has determined that there has been a period of inactivity, the length of which you can determine in the code. The user will not be booted out if they are actually using the file.
There are other options around file sharing and co-authoring that you may want to consider before you add code to make a file close, but if they don't work for you then this is a great option. Also you may want to consider about alerting the user about how the file might close with a pop up message or splashscreen when they open it, and you may want to add further code to save a backup copy before it closes.
Firstly we will just look at this simple solution and then look at how to add this extra functionality later in this tutorial.
You can download the basic file with the button below, or carry on further to learn how it works and add the extra functionality (recommended).
Download the already completed basic autoclose.XLSM file hereFirstly open a new workbook and save it as autoclose.xlsm , It doesnt matter what content you have in the cells if any at all.
Follow the simple steps below to add the code to your new workbook.
You will need to set the timer duration to whatever you feel is suitable. we have chosen 20 minutes.
Option Explicit
Dim DownTime As Date
Sub SetTimer()
'set the time duration (20mins here) the file can remain unattended for before close event
DownTime = Now + TimeValue("00:20:00")
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()
'Closes the file & ensures that an empty Excel shell does not remain on screen
If Application.Workbooks.Count > 1 Then
ThisWorkbook.Saved = True
ThisWorkbook.Close
Else
Application.Quit
End If
End Sub
We now only need to tell the workbook a few things that it needs to do when it first opens & closes and how to tell if the workbook has become inactive etc and all is done!
Just go back again to the Project Explorer Pane in the VB Editor window, double click ThisWorkbook and just as you did with the Module paste the following code into the window that opens and again hit save.
Option Explicit
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
The VB Editor window should now appear as below. Now hit save. you can close it now if you like.
That's it, all done!
Now close the form & reopen it, you will see that it will simply close after the time chosen in the code. You may want to change this to 30 seconds or something in order to test it out.
I mentioned earlier that you may want to consider about alerting the user about how the file might close with a pop up message or splashscreen when they open it, and you may want to add further code to save a backup copy of itself before it closes. That way if someone accidentally lets the file close they can easily retrieve any work they have partialy completed. Now we will add the following to enhance the workbook you have already created.
Please click here to see my tutorial on how to a a splash screen.
We will need to add some code into a new module.
Function DirectoryExist(sstr As String) 'checks if the save to folder exists
Dim lngAttr As Long
DirectoryExist = False
If Dir(sstr, vbDirectory) <> "" Then
lngAttr = GetAttr(sstr)
If lngAttr And vbDirectory Then _
DirectoryExist = True
End If
End Function
Sub SaveCopy()
'makes this workbook the active workbook and makes it the front window on the desktop
'to avoid the wrong excel file being saved if more than one excel files are open.
'Saves a copy of the file to the required folder - creates the folder if it does not yet exist
Dim dirstr As String, DateTime As String, SavePath As String
Dim wb As Workbook
'activate & maximise
ThisWorkbook.Activate
ActiveWindow.WindowState = xlMaximized
Set wb = ActiveWorkbook
'save a copy
dirstr = "C:\Users\Public\Backups"
DateTime = Format(CStr(Now), "dd-mm-yyyy" & " " & "hh-mm-ss")
SavePath = dirstr & "\Copy Of Manufacturing Plan" & " " & DateTime
If Not DirectoryExist(dirstr) Then
MkDir dirstr
wb.SaveAs Filename:=SavePath & ".XLSX", FileFormat:=51
Else
wb.SaveAs Filename:=SavePath & ".XLSX", FileFormat:=51
End If
End Sub
The above code contains a function that is called by the save procedure to check if the save directory exists, and the save procedure itself which will save to a directory it will create if it needs to.
The save procedure is set to always save to the public folder "C:\Users\Public\Backups" because we need to use a directory/folder that we can guarantee that any user on any machine can access. It will create the folder "Backups" the first time it runs because it will not exist by default.
Also please note that as we do not need to save the VBA code with any backup files created we will save the backups with the .xlsx file extension. The point of the backups is so that a user can retrieve any work in the sheets that they forgot to save, not the code behind the sheets.
The following procedure will to delete files that have been deemed to be of no use after a period of time.
Paste this code into into the same module as the above save procedure, on the first empty line directly after the "End Sub" line.
This procedure will be used to delete any files in the backups folder older than 7 days. You can change this number in the code to any number you like. We do this because it is unlikely that a user is going to want to retrieve any unsaved data after this time, and we do need to consider conserving disk space in a workplace environment.
Sub DeleteOldFiles()
'Clear out all files over 7 days old from Dir_Path folder.
Dir_Path = "C:\Users\Public\Manufacturing Plan Backups"
'Set the number of days
iMaxAge = 7
Set oFSO = CreateObject("Scripting.FileSystemObject")
'Check that the folder exists
If oFSO.FolderExists(Dir_Path) Then
For Each oFile In oFSO.GetFolder(Dir_Path).Files
'Looks at each file to check if it is older than 7 days and deletes older files
If DateDiff("d", oFile.DateLastModified, Now) > iMaxAge Then
oFile.Delete
End If
Next
End If
End Sub
To do this we will first create another Userform that will be used as a pop up warning to the user that the workbook is about to close. It wil have a button on it that will allow the user to canel the shutdown and re-start the timer. It will also have a neat countdown progress bar to show the user how long they have before the workbook will automatically close if they take no action.
