Close an unused workbook automaticcly after a specific time

[jxb]

I have got a spreadsheet which is being used as a database. I would like the spreadsheet to close automatically if the user has not "touched" it for a specific amount of time (say 1hr).

2 scenarios:

a/ The user is working in Excel but with another workbook.
b/ The user has the excel spreadsheet open but is working with another application, say Word

I experimented with Workbook_WindowDeactivate but I do not know how to stop the process if the Workbook is reactivated (Maybe a DO ...LOOP calling a function returning a True/False statement on the event Workbook_WindowActivate !!). My way of thinking is the following

Workbook is deactivated
Start a timer
If the workbook is not reactivated with 1hr, save and close (no user intervention wanted)
Else stop timer
Repeat process

Same idea applies if the user is working with another application (scenario b/ above)

Thanks

Regards

JXB

 

[mikerickson]

Use the Selection_Change event in ThisWorkBook combined with a Close routine. so that everytime the user makes a selection from one of the sheets

Remove old On_Time
On_Time Now+1hour, "my Close Routine"

 

[erik.van.geit]

Hi, jxb
Welcome to the Board !!!!!

Cannot find where I posted this already. (not sure if I did)
Add some code to your project. Experiment a bit with shorter "timeout"
Currently it is set at 30 seconds.

WORKBOOKmodule

Option Explicit


Private Sub Workbook_Open()

    If Left(ThisWorkbook.Name, 4) <> "copy" Then
    'On Error Resume Next
    'Sheets.Add.Name messagesh
    'On Error GoTo 0
    Sheets(messagesh).Visible = False
    Else
    Exit Sub
    End If

LastEventTime = Timer
MsgBox "The workbook " & ThisWorkbook.Name & " will be closed unsaved if inactive for more then " & nonactive & " seconds" & Chr(10) & _
"a copy will be saved in the same map as the original", 48, "ACTIVITY"
time_out (True)

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Run "restart"
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Run "restart"
End Sub

Private Sub Workbook_Activate()
Run "restart"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Run "cancel_schedule"
End Sub

TO INSTALL IN THISWORKBOOK CODE WINDOW:
1. Rightclick the little Excel-icon on the topleft of your page just beside the Filemenu
2. Select "View Code" in drop down menu
3. VBE window will open ... paste code in and exit VBE

GENERAL module

Option Explicit

Global LastEventTime As Double
Global when As Variant

'**** EDIT ****
Global Const nonactive As Integer = 30          'number of seconds without activity
Global Const extratime As Integer = 10          'number of "grace" seconds
Global Const closecopy As Boolean = False       'if False then copy will remain on screen
Global Const messagesh As String = "warning"    'when autoclose this sheet will show up in copy
'**** END EDIT ****

Sub restart()
    cancel_schedule
    time_out (True)
End Sub

Sub time_out(Optional flag As Boolean)
'Erik Van Geit
Dim action As Integer
Dim lasttime As String
Dim file_name As String

Const copy_prefix As String = "copy "           'string to put before the name when workbook is copied

    If flag Then
    when = Now + nonactive / 60 / 60 / 24
    'Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(0, 1) = when
    Application.OnTime when, "time_out"
    Exit Sub
    End If

'last chance
    lasttime = Format(Now + extratime / 60 / 60 / 24, "hh:mm:ss")
    action = CreateObject("WScript.Shell").Popup("Click OK before " & lasttime & vbLf & _
    "Else this workbook will be closed", 10, "Autoclose")

    If action = 1 Then
    restart
    Exit Sub
    End If

    With Sheets(messagesh)
    .Visible = True
    .Activate
    .Range("B2") = "The original workbook " & ThisWorkbook.Name & " was closed on " & Format(Date, "dd-mmmm-yyyy") & " at " & Format(Time, "hh:mm:ss")
    .Range("B3") = "There was no activity during " & nonactive & " seconds"
    .Range("B4") = "The warning popup - which lasted on screen for " & extratime & " seconds - wasn't clicked."
    .Hyperlinks.Add Anchor:=.Range("B6"), Address:=ThisWorkbook.FullName, TextToDisplay:="LINK TO ORIGINAL WORKBOOK"
    End With
  
    With ThisWorkbook
    file_name = .Path & Application.PathSeparator & copy_prefix & .Name
    cancel_schedule
    Application.DisplayAlerts = False
    flag = False
    On Error Resume Next
    Workbooks(copy_prefix & .Name).Close
    .SaveAs file_name
    Application.DisplayAlerts = True
    If closecopy Then .Close False
    End With

End Sub

Private Sub cancel_schedule()
'MsgBox "cancelled"
On Error Resume Next
Application.OnTime EarliestTime:=when, Procedure:="time_out", schedule:=False
'Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2) = when
On Error GoTo 0
End Sub

There are some features you didn't ask for.
- warning popup "10 seconds"
- workbook is copied: copy is left open with message what happened + link to original workbook

you can disable those things if you want

kind regards,
Erik

 

[jxb]

Erik,

Thanks a lot for your help and VBA code. I do not think I would have been able to figure it out. A questions though
In Time_out sub:

------------------------------------------------------------------------------------------------------------------------

Sub Time_out(Optional flag As Boolean)

Dim action As Integer
Dim lasttime As String
Dim file_name As String

'Const copy_prefix As String = "copy " 'string to put before the name when workbook is copied

If flag Then
When = Now + nonactive / 60 / 60 / 24
Application.OnTime When, "Time_out"
Exit Sub
End If

What does the IF statement above do?

Etc...

End sub
------------------------------------------------------------------------------------------------------------------------

I am working my way through to suppress the line regarding the "Last chance" and saving a copy of the file
I just want save and close the file after 1hr (nonactive=3600)

Thanks

A lot for your help. Much appreciated

Regards

JXB

 

[erik.van.geit]

you're WELCOME

Please use the codetags when posting code.

what does the IF do ?

If flag Then 
When = Now + nonactive / 60 / 60 / 24 
Application.OnTime When, "Time_out" 
Exit Sub 
End If

the procedure "time_out" is used to start another loop when flag = true
the other code will not be read, because of the "exit sub"

I deleted all lines with extras although they were there for good reasons.
so CAVEAT !!! The main problem with this code is "save without asking". I can imagine enough problems with that.
(Hence my "copy"system.)

I changed the time to 10 seconds to test.

WORKBOOKmodule

Option Explicit

Private Sub Workbook_Open()

MsgBox "The workbook " & ThisWorkbook.Name & _
" will be closed (saved) if inactive for more then " & nonactive & " seconds." _
, 48, "ACTIVITY"
time_out (True)

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Run "restart"
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Run "restart"
End Sub

Private Sub Workbook_Activate()
Run "restart"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Run "cancel_schedule"
End Sub

GENERAL module

Option Explicit

Global when As Variant

'**** EDIT ****
Global Const nonactive As Integer = 10          'number of seconds without activity
'**** END EDIT ****

Sub restart()
    cancel_schedule
    time_out (True)
End Sub

Sub time_out(Optional flag As Boolean)
'Erik Van Geit
Dim action As Integer
Dim file_name As String


    If flag Then
    when = Now + nonactive / 60 / 60 / 24
    Application.OnTime when, "time_out"
    Exit Sub
    End If


    With ThisWorkbook
    cancel_schedule
    .Close True
    End With

End Sub

Private Sub cancel_schedule()
On Error Resume Next
Application.OnTime EarliestTime:=when, Procedure:="time_out", schedule:=False
On Error GoTo 0
End Sub

 

[ArtQueddeng]

Thank you very much Eric, I will study this "Timer Process" in depth tonight, together with the two examples. I believe this will solve my problem.
Thanks again.
Regards,
ARTURO...

 

[erik.van.geit]

You're WELCOME !

I think you wanted to reply here
http://www.mrexcel.com/board2/viewtopic.php?p=1339824

ENJOY the Board

 

[MasterChief]

I have just found this thread and it was exactly what I have been looking for, however when I run this I get a "Runtime error 9" Subscript out of range, at this point.

Could you tell me what I am doing wrong.

Many thanks.

With Sheets(messagesh)
.Visible = True
.Activate
.Range("B2") = "The original workbook " & ThisWorkbook.Name & " was closed on " & Format(Date, "dd-mmmm-yyyy") & " at " & Format(Time, "hh:mm:ss")
.Range("B3") = "There was no activity during " & nonactive & " seconds"
.Range("B4") = "The warning popup - which lasted on screen for " & extratime & " seconds - wasn't clicked."
.Hyperlinks.Add Anchor:=.Range("B6"), Address:=ThisWorkbook.FullName, TextToDisplay:="LINK TO ORIGINAL WORKBOOK"
End With

 

[erik.van.geit]

see the line
Global Const messagesh As String = "warning"

do you have a sheet called "warning" ?

 

[Nyanko]

Apologies for bumping an old topic, but I would love to get this code working !

However I get and "ambiguous name detected" error for the word "Format! at line :

    lasttime = Format(Now + extratime / 60 / 60 / 24, "hh:mm:ss")

I am running excel 2000 with VB 6.3

Any advice or guidence would be appriciated !