Auto save and close workbook (in a share) if Screen/Workstation is Locked

Question

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.

Answer 1

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