Excel VBA - Auto-close routines

autoclose.vb

'These routines will auto-close a workbook after a period of inactivity, useful for centrally-accessed
'non-shared workbooks that need to be accessed by multiple people. Also optional indicator to show who has
'opened the file, in case Excel only shows 'another user.'

'Put the following code in the 'ThisWorkbook' module:

'Timeout in seconds
Const Timeout As Integer = 300

'Flag to enable auto-close
Const blnEnableTimeout As Boolean = True

'Choose a name to refer to this file to - e.g. 'Team Schedule', 'Monthly Stats' etc
Const strFileTitle as string = "My File"

Private Sub Workbook_Open()
    'If this file has not been opened read-only, create a text file indicating who has opened it and start the idle timer
    
    Dim strFilename As String
    
    If Not ThisWorkbook.ReadOnly Then
        Delete_file
        strFilename = ThisWorkbook.Path & "\" & strFileTitle & " opened by " & Environ("USERNAME") & ".txt"
        
        Open strFilename For Output As #1
        Write #1, Now()
        Close #1
        
        If blnEnableTimeout Then Start_Timer
    End If
End Sub


Private Sub Workbook_BeforeClose(Cancel As Boolean)
    'Delete text file & clear timer on close
    If Not ThisWorkbook.ReadOnly Then
        Delete_file
        Clear_Timer
        Application.StatusBar = False
    End If
End Sub


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    'Each time a change is made to the workbook, reset the timer (clear and restart)
    If Not ThisWorkbook.ReadOnly And blnEnableTimeout Then
        Clear_Timer
        Start_Timer
    End If
End Sub


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    'Each time a new cell is selected, reset the timer (clear and restart)
    If Not ThisWorkbook.ReadOnly And blnEnableTimeout Then
        Clear_Timer
        Start_Timer
    End If
End Sub



'Helper routines

Private Sub Delete_file()
    'Delete the file stating who has opened it
    On Error Resume Next
    Kill ThisWorkbook.Path & "\" & strFileTitle & " opened by*.txt"
    On Error GoTo 0
End Sub


Private Sub Clear_Timer()
    'Clear the timer - scattergun approach to ensure that all timers in the time window are DEFINITELY closed
    Dim x As Integer
    For x = 1 To Timeout + 20
        On Error Resume Next
        Application.OnTime EarliestTime:=Now + TimeSerial(0, 0, x), Procedure:="Close_Book", Schedule:=False
        On Error GoTo 0
    Next x
End Sub


Private Sub Start_Timer()
    'Set the clock running, display a message in the statusbar
    Application.OnTime EarliestTime:=Now + TimeSerial(0, 0, Timeout), Procedure:="Close_Book", Schedule:=True
    Application.StatusBar = "Whereabouts sheet will close at " & Now + TimeSerial(0, 0, Timeout) & " if no further activity is detected"
End Sub