Timer and timed close of a spreadsheet

**jeffwest2** · 10-19-2009, 06:59 AM

I have within my workbooks a procedure that if the book has not been touched for an hour it auto saves and closes.

My Issue: What I want to do is either

1. Have a count down timer counting down on the status bar from 60 minutes to 00, which upon reaching 00 will trigger the close event, without any intervention i.e. i don't want a message box to appear as it doesn't now.

2. If the workbook is touched, then the clock resets to 60 minutes

or

1. Have a auto closing message box pop up with 10 minutes to go to say that this workbook will close in ten minutes, and then count down the time.

2. Again reset the timer if it is used.

I basically want to have the countdown time visible, but without having any intervention from users in starting or stopping it other than using/not using the sheet.

Most of the solutions i have found seem to have some form of user intervention, i.e. messagebox with yes no buttons.

**Leith Ross** · 10-19-2009, 06:05 PM

Hello jeffwest2,

This macro code will close and save the workbook automatically if the mouse hasn't been moved for an hour. Copy this code to a VBA module. You will need to add a macro to the Workbook_Open event and a macro to the Workbook_BeforeClose() event. Samples are shown below.

'Written: October 19, 2009
'Author:  Leith Ross
'Summary: Close and Save the workbook if mouse hasn't been moved in 1 hour.

Private Type POINTAPI
  X As Long
  Y As Long
End Type

Private Declare Function GetCursorPos _
  Lib "User32.dll" (ByRef lpPoint As POINTAPI) As Long
  
Private Sub MouseMonitor()

  Static Cnt As Long
  Dim CurPos As POINTAPI
  Static Mins As Long
  Static PrevX As Long
  Static PrevY As Long
  Static Secs As Long
  
    GetCursorPos CurPos
    
    If PrevX <> CurPos.X Or PrevY <> CurPos.Y Then
       Secs = 0
       Mins = 0
       Cnt = 0
       PrevX = CurPos.X
       PrevY = CurPos.Y
       Application.StatusBar = "60 minutes till workbook closes"
    End If
    
       Secs = Secs + 1
       If Secs >= 3600 Then
          ActiveWorkbook.Close True
          Exit Sub
       End If
       
       Cnt = Cnt + 1
       If Cnt >= 60 Then
          Mins = Mins + 1
          Application.StatusBar = 60 - Mins & " minutes till workbook closes"
          Cnt = 0
       End If
    
    Application.OnTime Now() + TimeValue("00:00:01"), "MouseMonitor", , True
    
End Sub

Sub MouseMonitorOn()

   Application.StatusBar = ""
   Application.DisplayStatusBar = True
   Application.OnTime Now() + TimeValue("00:00:01"), "MouseMonitor", , True
  
End Sub

Sub MouseMonitorOff()

   Application.DisplayStatusBar = False
   Application.OnTime Now() + TimeValue("00:00:01"), "MouseMonitor", , False
  
End Sub

Workbook Module Code

Private Sub Workbook_Open()
    MouseMonitorOn
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    MouseMonitorOff
End Sub

**jeffwest2** · 10-20-2009, 04:50 AM

Leith

Cheers for this, i will give it as go and see how i get on.

**jeffwest2** · 10-20-2009, 06:57 AM

Below is the code that i am using, i have added the bits from yours and added the module, this works fine, it counts down from 10 minutes to 0, the problems i am having.

1. If i add the MouseMonitorOff into the auto close, it just closes the statusbar at the bottom or does nothing.

2. If i add it to the Workbook_BeforeClose, it does nothing.

I guess what i need, and i can't seem to get the coding right, is exaclty what i have but if it closes because the time is up, it just saves closes, if however the user closes the workbook, then it ask if they want to save the changes, any help would be greatly appreciated

Private Changed As Boolean

Public bIsClosing As Boolean
Public bMadeChanges As Boolean
Private Sub Workbook_Open()

 MouseMonitorOn

Call ShowAll
ThisWorkbook.Sheets("Macros Disabled").Activate

LogInformation ThisWorkbook.Name & " opened by " & _
        Application.UserName & " " & Format(Date, "yyyy-mm-dd hh:mm")
        
Worksheets("Team Scorecard").Unprotect Password:="scorecard"
ActiveWorkbook.UpdateLinks = xlUpdateLinksAlways
Worksheets("Team Scorecard").Protect Password:="scorecard"

Sheets("PaperTrail").Visible = False

On Error Resume Next
Worksheets("Team Scorecard").Activate
Cells(3, 20).Value = ActiveWorkbook.BuiltinDocumentProperties("last save time").Value


Changed = False
Application.OnTime Now + TimeValue("00:10:00"), procedure:="ThisWorkbook.Auto_Close"
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, _
ByVal Source As Range)
bMadeChanges = True
Changed = True
End Sub

Private Sub Auto_Close()

MouseMonitorOff

If Changed = False Then
ThisWorkbook.Close SaveChanges:=True
End If
Changed = False
Call Application.OnTime(Now + TimeValue("00:10:00"), "ThisWorkbook.Auto_Close")
End Sub

Sub LogInformation(LogMessage As String)
Const LogFileName As String = "v:\scorecards\Bath\logfiles\logfile.LOG"
Dim FileNum As Integer
    FileNum = FreeFile ' next file number
    Open LogFileName For Append As #FileNum ' creates the file if it doesn't exist
    Print #FileNum, LogMessage ' write information at the end of the text file
    Close #FileNum ' close the file
End Sub
Sub HideSaveShow()
Dim CurSht As Worksheet

    With Application
    .EnableEvents = False
    .ScreenUpdating = False
    Set CurSht = ActiveSheet
    Call HideAll
    Call ShowAll
    CurSht.Activate
    .EnableEvents = True
    .ScreenUpdating = True
    End With

End Sub

Sub HideAll()
Dim sht As Worksheet

    With ThisWorkbook
    .Sheets("Macros Disabled").Visible = xlSheetVisible
    
        For Each sht In .Worksheets
        If sht.Name <> "Macros Disabled" Then sht.Visible = xlSheetVeryHidden
        Next sht
    
    .Save
    
    End With

End Sub

Sub ShowAll()
Dim sht As Worksheet

If bIsClosing Then Exit Sub

    With ThisWorkbook
    
        For Each sht In .Worksheets
        sht.Visible = xlSheetVisible
        Next sht

    .Sheets("Macros Disabled").Visible = xlSheetVeryHidden
    
    End With
    
    bMadeChanges = False
    
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
 
If bIsClosing Then Exit Sub
'If Changed = False Then Exit Sub



'LogInformation ThisWorkbook.Name & " Closed by " & _
'Application.UserName & " " & Format(Date, "yyyy-mm-dd hh:mm")

Dim response As Integer

    With ThisWorkbook

        If bMadeChanges Then
        response = MsgBox("Save Changes?", vbYesNoCancel, "SAVE")
        Else
        .Close False
        End If

        Select Case response

        Case vbYes
        bIsClosing = True
        bMadeChanges = False
        HideAll
        .Close False
        bIsClosing = False '

        Case vbCancel
        Cancel = True

        Case vbNo
      .Saved = True

        End Select

End With

End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If SaveAsUI Then
    MsgBox "Sorry, you are not allowed to use Save As.", vbCritical, "No Save As"
    Cancel = True
    Exit Sub
    End If

If bIsClosing Then Exit Sub
Call HideSaveShow
Cancel = True
bMadeChanges = False

End Sub