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.

jovicks · Answer 1 · 2019-07-20T21:05:00.430

1

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?

edited Jul 20 '19 at 21:05

answered Jul 20 '19 at 20:54

jovicks

87
8

1

How dangerous is this! In our work people need to lock their station even just to get coffee, for security reasons. Imagine someone in the process of making changes but not quite done, let alone wanting to make changes cause he made some errors, only at return at the desk to discover someone else has started work on a faulty file. That being said, if this works for you it's a nice piece of code. – JvdV Jul 20 '19 at 21:26
1

It's a perfectly good policy to ask employees to lock their computers!! I would recommend a different approach than this though. Why not set a global `Lastchanged` variable that is automatically reset on a sheet calculation or something and has a `Application.Run` that will run the save and close only when no calculations have happened after like 35 minutes or whatever. I do like the Lock approach, but I think that might be overkill. If this doesn't work, I'll be back on later and can demonstrate. – pgSystemTester Jul 20 '19 at 21:36
1

Here's an example of the Application.Run approach: See this as an example: https://stackoverflow.com/questions/57060459/how-to-refresh-database-data-in-excel-at-regular-intervals/57060897#57060897 – pgSystemTester Jul 20 '19 at 21:37
@PGSystemTester will try it out. Thanks for the tip. – jovicks Jul 20 '19 at 21:42
@JvdV in this case the workbook will only be appended with records of text and no complex formulas or other processes are involved. So risk is very minimal. – jovicks Jul 20 '19 at 21:43

pgSystemTester · Accepted Answer · 2019-07-22T16:49:16.573

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

Thanks @PGSystemsTester So if I understood, Workbook_SheetSelectionChange is executed with every change in the workbook - like an interrupt. So it wont be called manually from the macro. I will add this before actually checking if screen is locked. By no means I was criticising users who lock the screen. It has become 2nd nature for me to lock the screen before leaving my desk. I think it is crucial for security reasons. — jovicks, Jul 20 '19 at 22:46
It's actually executed on every `Workbook_SheetSelectionChange` meaning every time the user clicks on a different cell. A "change" in workbook is typically defined as `Workbook_SheetChange` which would be every time a user changes a cell value. Selection change captures more activity and given how it shouldn't impact performance, that was why I chose it. I think locking the machine is probably a distraction. You could put in another if-statement to yell at the user if . `If DateDiff("S", Now, LastCalculate) < 600 Then Application.Speech.Speak "Hey! In ten minutes, you're done!"` — pgSystemTester, Jul 20 '19 at 22:55
I am getting the below popup error: Cannot run the macro 'Workbook.xlsm!*******'. The macro may not be available in >this workbook or all macros may be disabled. - Cannot find the cause.. debugging would not give any clue. — jovicks, Jul 21 '19 at 09:14
thanks a million @PGSystemTester this was a very useful and fun learning experience for me! Will use your answer as a model and tweak it as necessary. It is very simple to understand and extend. Answer accepted. — jovicks, Jul 22 '19 at 21:27

jovicks · Answer 3 · 2019-07-21T11:01:42.000

@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?

Hi! I just saw this. I'll update my answer with a couple things that will make it a little more efficient. — pgSystemTester, Jul 21 '19 at 23:11

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

3 Answers3