Auto close spreadsheet timer not working correctly

[eli_m]

Hi all,

I have this Timeout_Module:

Option Explicit
Public DownTime As Double
Sub StartTimer()
    DownTime = Now + TimeSerial(0, 30, 0)
    Application.OnTime DownTime, "ShutDown"
End Sub
Sub StopTimer()
    On Error Resume Next
    Application.OnTime DownTime, "ShutDown", , False
 End Sub
Sub ShutDown()
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
End Sub

It seems to work fine but after 30 minutes it closes my spreadsheet regardless of:
Call StopTimer
Call StartTimer

Restarting the timer the below code:

Option Explicit
' Ignore Errors when Worksheet Activated
Private Sub Worksheet_Activate()

Call StartTimer 'Start Timeout timer

Dim r As Range: Set r = Range("A2:AQ200")
Dim cel As Range

For Each cel In r
  With cel
    .Errors(8).Ignore = True 'Data Validation Error
    .Errors(9).Ignore = True 'Inconsistent Error
    .Errors(6).Ignore = True 'Lock Error
  End With
Next cel

End Sub

Private Sub Worksheet_Deactivate()
    Call StopTimer 'Stop Timeout timer so it can stay open when on other sheets
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = False Then
Application.Calculate ' Refresh for Grey Line
End If
Call StopTimer 'Stop Timeout timer
Call StartTimer 'Restart Timeout timer
End Sub

Private Sub Worksheet_Calculate()

' Ignore Errors after Sorting
Dim r As Range: Set r = Range("A2:AQ200")
Dim cel As Range

For Each cel In r
    With cel
        .Errors(8).Ignore = True 'Data Validation Error
        .Errors(9).Ignore = True 'Inconsistent Error
        .Errors(6).Ignore = True 'Lock Error
    End With
Next cel
Call StopTimer 'Stop Timeout timer
Call StartTimer 'Restart Timeout timer
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Const sURI As String = "https://cases.com/ui/cases/"

    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("Q3:Q200")) Is Nothing Then

        On Error GoTo ErrLine
        Application.EnableEvents = False

        With ActiveWorkbook.Styles("Followed Hyperlink").Font
            .Color = RGB(0, 0, 0)
        End With

        If Target.Value <> "" Then
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "A"), Address:= _
                                       sURI & Target.Value, TextToDisplay:=Cells(Target.Row, "A").Value
        Else
            Cells(Target.Row, "A").Hyperlinks.Delete
        End If
 
        With Cells(Target.Row, "A").Font
            .Parent.Style = "Normal"
            .Name = "Calibri"
            .Size = 12
            .Bold = True
            .Color = vbBlack
            .Underline = xlUnderlineStyleNone
        End With
    End If

    If Target.CountLarge / Rows.Count = Int(Target.CountLarge / Rows.Count) Then Exit Sub    'Exit code if whole columns are edited

    ' Copy from Line 200 into deleted cells
    Dim Changed As Range, c As Range

    Set Changed = Intersect(Target, Columns("A:AQ"))
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        For Each c In Changed
            If Len(c.Text) = 0 Then Cells(200, c.Column).Copy Destination:=c
        Next c
        Application.EnableEvents = True
    End If


    'Ignore Errors with Worksheet Clicks
    Dim r As Range: Set r = Range("A2:AQ200")
    Dim cel As Range

    For Each cel In r
        With cel
            .Errors(8).Ignore = True    'Data Validation Error
            .Errors(9).Ignore = True    'Inconsistent Error
            .Errors(6).Ignore = True    'Lock Error
        End With
    Next cel
    
ErrLine:        'Just in case, enable event
    Application.EnableEvents = True
    

End Sub

Even though I am entering text or clicking around the spreadsheet will still close after 30 minutes intermittently.
I can't seem to put a finger on why it is doing this.


Any help would be greatly appreciated!

Thank you in advance

 

[offthelip]

I have had probelms with starting and resetting timers before, what I suggest you could do is change you system so that you start the timer when the worksheet activates, then rather than resetting it when you make a selection change or deactivate the worksheet just record the time it occurs in another public variable, then when down time expires reset the timer for this recorded time plus 30 minutes. This means you always allow the timer to expire, only close the workbook if it expires 30 minutes after the reset which you can detect by comparing the time of the last change

 

[eli_m]

I have had probelms with starting and resetting timers before, what I suggest you could do is change you system so that you start the timer when the worksheet activates, then rather than resetting it when you make a selection change or deactivate the worksheet just record the time it occurs in another public variable, then when down time expires reset the timer for this recorded time plus 30 minutes. This means you always allow the timer to expire, only close the workbook if it expires 30 minutes after the reset which you can detect by comparing the time of the last change

That seems like a good idea - Do you have an example of how I can do this?

Thanks!

 

[offthelip]

try someting like, this all the code is untested but should give you the idea:

'Option Explicit note I changed this because I never use it, you may need to declare any variables I generate as variant which I have missed
Public NextTime As Double
Public Lastchange As Double
Public checktime As Boolean

Sub checktimer()
  deltalimit=(TimeSerial(0, 29, 59)
    deltatime = Now() - Lastchange
    If deltatime > deltalimit And checktime Then
    Call ShutDown
    Else
    
    NextTime = Now + (TimeSerial(0, 30, 0) - deltatime)
    Application.OnTime NextTime, "ShutDown"
    End If
End Sub
Sub ShutDown()
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
End Sub



Private Sub Worksheet_Activate()

'Call StartTimer 'Start Timeout timer
checktime = True
Lastchange = Now()
'' rest of your code here

End Sub

Private Sub Worksheet_Deactivate()
'    Call StopTimer 'Stop Timeout timer so it can stay open when on other sheets
 checktime = False
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = False Then
Application.Calculate ' Refresh for Grey Line
End If
'Call StopTimer 'Stop Timeout timer
'Call StartTimer 'Restart Timeout timer
checktime = True
Lastchange = Now()

End Sub

 

[offthelip]

I have just realised that this line:

Application.OnTime NextTime, "ShutDown"

should be:

Application.OnTime NextTime, "checktimer"

 

[eli_m]

I have just realised that this line:

Application.OnTime NextTime, "ShutDown"

should be:

Application.OnTime NextTime, "checktimer"

I have this as my Timeout_Module:

Public NextTime As Double
Public Lastchange As Double
Public checktime As Boolean
Sub checktimer()
  deltalimit = (TimeSerial(0, 19, 59))
    deltatime = Now() - Lastchange
    If deltatime > deltalimit And checktime Then
    Call ShutDown
    Else
  
    NextTime = Now + (TimeSerial(0, 20, 0) - deltatime)
    Application.OnTime NextTime, "checktimer"
    End If
End Sub
Sub ShutDown()
    With ThisWorkbook
        Application.DisplayAlerts = False
        .Close Savechanges:=True
        Application.DisplayAlerts = True
    End With
End Sub

And added all the other code you posted too but it only sometimes works do you know what I could be doing wrong?

1. I open the spreadsheet
2. click around - change values etc.
3. walk away from the computer for 45 minutes
4. Spreadsheet is still opened and has not closed


I played around with changing the timer to just 1 minute and it worked sometimes but I could leave it for 10 minutes and it would still be open so I am not sure whats happening.


Rest of the code is:

Option Explicit
' Ignore Errors when Worksheet Activated
Private Sub Worksheet_Activate()

'Check Timeout timer
checktime = True
Lastchange = Now()

Dim r As Range: Set r = Range("A2:AQ200")
Dim cel As Range

For Each cel In r
  With cel
    .Errors(8).Ignore = True 'Data Validation Error
    .Errors(9).Ignore = True 'Inconsistent Error
    .Errors(6).Ignore = True 'Lock Error
  End With
Next cel

End Sub

Private Sub Worksheet_Deactivate()
 checktime = False 'Stop Timeout timer so it can stay open when on other sheets
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = False Then
Application.Calculate ' Refresh for Grey Line
End If

'Check Timeout timer
checktime = True
Lastchange = Now()

End Sub

Private Sub Worksheet_Calculate()

' Ignore Errors after Sorting
Dim r As Range: Set r = Range("A2:AQ200")
Dim cel As Range

For Each cel In r
    With cel
        .Errors(8).Ignore = True 'Data Validation Error
        .Errors(9).Ignore = True 'Inconsistent Error
        .Errors(6).Ignore = True 'Lock Error
    End With
Next cel

End Sub

 

[offthelip]

I have spotted the probelm I didn't call checktimer when the workhseet is activated: so change the workhseet activate sub like this:

Option Explicit
' Ignore Errors when Worksheet Activated
Private Sub Worksheet_Activate()
checktime = False                                   ' add this line
Call checktimer                                       ' add this line
'Check Timeout timer
checktime = True
Lastchange = Now()

Dim r As Range: Set r = Range("A2:AQ200")
Dim cel As Range

For Each cel In r
  With cel
    .Errors(8).Ignore = True 'Data Validation Error
    .Errors(9).Ignore = True 'Inconsistent Error
    .Errors(6).Ignore = True 'Lock Error
  End With
Next cel

End Sub

 

[eli_m]

I have spotted the probelm I didn't call checktimer when the workhseet is activated: so change the workhseet activate sub like this:

Option Explicit
' Ignore Errors when Worksheet Activated
Private Sub Worksheet_Activate()
checktime = False                                   ' add this line
Call checktimer                                       ' add this line
'Check Timeout timer
checktime = True
Lastchange = Now()

Dim r As Range: Set r = Range("A2:AQ200")
Dim cel As Range

For Each cel In r
  With cel
    .Errors(8).Ignore = True 'Data Validation Error
    .Errors(9).Ignore = True 'Inconsistent Error
    .Errors(6).Ignore = True 'Lock Error
  End With
Next cel

End Sub

Sadly that didn't work either but I think we are on the right track. If I change the time to 1 minute and wait THEN run the Module manually it closes. If I try and close it before 1 minute it doesn't close.
So I think the module is all good just not running the module?

 

[eli_m]

I was just doing some testing and noticed that if the Sheet is loaded up when the Workbook loads then the timer doesn't close the sheet.
If I change to another sheet and then go back to the original sheet then the timer will work after the set number of minutes and close the workbook.

So the question is why doesn't it run when I open the workbook? I even tried:

Private Sub Workbook_Open()

'Start Timeout Timer
        checktime = False
        Call checktimer
'Check Timeout timer
        checktime = True
        Lastchange = Now()

and that didn't work either.. we are getting close the answer!

 

[offthelip]

I have discovered what the problem is, The code you adding to the workbook open is correct and does work , the probelm is the check on the time in the check timere module. I put a few msgbox in that routine and checked it out. The probelm arise because I my efforts to "bracket" the time it triggers which is never going to be accurate. this code will catch the close event but may take 4 minutes instead of 2. Having identified the probelm perhaps you can fix it to your satisfaction:
My checktimer:

Sub checktimer()
  deltalimit = (TimeSerial(0, 1, 59))
    deltatime = Now() - Lastchange
   MsgBox "checktimer runs " & deltatime
   
    If deltatime > deltalimit And checktime Then
    Call ShutDown
    Else
    If deltatime <= deltalimit Then
    NextTime = Now + (TimeSerial(0, 2, 0) - deltatime)
    Else
    NextTime = Now + (TimeSerial(0, 2, 0))
    End If
    MsgBox NextTime
    Application.OnTime NextTime, "checktimer"
    End If
End Sub