Autoclose Excel Workbook with warning popup

Question

I have a situation where multiple users will need to access a workbook (want to avoid using the 'Share Workbook' option due to all the problems). I've determined that a possible solution to this is to get the workbook to automatically close after 15 minutes of inactivity.

I would also like a message to pop up after the 15 minutes which alerts the user that unless they click the 'okay' button, the workbook will close. If they click the button, I would like the counter to start over, and ideally if they don't click anything the workbook will automatically closer after a further 1 minute.

I have found some code online which I have used. The workbook successfully closes after a specified time but I can't figure out how to get the message box to pop up. Would appreciate any help, thanks!

Code I used is below:

In module 1:

Dim DownTime As Date

Sub SetTimer()
    DownTime = Now + TimeValue("0:15: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()
    Application.DisplayAlerts = False
    With ThisWorkbook
        .Saved = True
        .Close
    End With
End Sub 

And in ThisWorkbook:

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

Answer 1

Try the below ShutDown procedure:

Sub ShutDown()
    If CreateObject("WScript.Shell").PopUp("Close Excel?", 60, "Excel", vbOKCancel + vbQuestion + vbSystemModal) = vbCancel Then
        StopTimer
        SetTimer
        Exit Sub
    End If
    Application.DisplayAlerts = False
    With ThisWorkbook
        .Saved = True
        .Close
    End With
End Sub

Answer 2

Never 'share' Excel files on a network drive with coworkers. You will encounter all kinds of problems, including workbook corruption, and other things. Try this script, to auto-close your Excel files after n-minutes of inactivity.

To start, add the following code to a standard macro module. Note that there are three routines to be added: Dim DownTime As Date

Sub SetTimer()
    DownTime = Now + TimeValue("01:00: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()
    Application.DisplayAlerts = False
    With ThisWorkbook
        .Saved = True
        .Close
    End With
End Sub

The next routines (there are four of them) need to be added to the ThisWorkbook object. Open the VBA Editor and double-click on the ThisWorkbook object in the Project Explorer. In the code window that Excel opens, place these routines:

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

See this for all info.

http://excelribbon.tips.net/T008192_Forcing_a_Workbook_to_Close_after_Inactivity.html