Close Workbook after idle for 30 seconds

[Herbiec09]

Good morning All,

Would anyone be able to assist with a vba code that will automatically close a workbook and save changes once it has been idle for a certain amount of time, say 30 seconds?

Thank you

Herbie C

 

[ranman256]

wow, 30 seconds is not much time....

open the VBE window: Alt-F11,
in the far left PROJECT window pane,
under the VBAProject (your workbook)
dbl-click the ThisWorkbook object,

PASTE THE FOLLOWING CODE:

Private Sub Workbook_Open()
StartTimer
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
ResetCount
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
ResetCount
End Sub

then in a MODULE, paste this code:

Option Explicit
Public gCount As Long
Public Const kLIMIT = 30      '30 SEC LIMIT

Sub Timer()
Dim tTime
    tTime = Now + TimeValue("00:00:01")
    Application.OnTime tTime, "ClickTimer"
End Sub

Sub ClickTimer()
Dim tTime

tTime = tTime - TimeSerial(0, 0, 1)
gCount = gCount + 1
Debug.Print gCount

If gCount > kLIMIT Then
    'MsgBox "Countdown complete."
    ActiveWorkbook.Close True
    Exit Sub
End If
Call Timer
End Sub


Public Sub ResetCount()
gCount = 0
End Sub

Public Sub StartTimer()
ResetCount
ClickTimer
End Sub

When the workbook opens, it starts counting to kLIMIT.
when a user types , it resets to 0.

 

[Herbiec09]

Thank you, much much appreciated

 

[gfdwer2]

wow, 30 seconds is not much time....

open the VBE window: Alt-F11,
in the far left PROJECT window pane,
under the VBAProject (your workbook)
dbl-click the ThisWorkbook object,

PASTE THE FOLLOWING CODE:

Private Sub Workbook_Open()
StartTimer
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
ResetCount
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
ResetCount
End Sub

then in a MODULE, paste this code:

Option Explicit
Public gCount As Long
Public Const kLIMIT = 30      '30 SEC LIMIT

Sub Timer()
Dim tTime
    tTime = Now + TimeValue("00:00:01")
    Application.OnTime tTime, "ClickTimer"
End Sub

Sub ClickTimer()
Dim tTime

tTime = tTime - TimeSerial(0, 0, 1)
gCount = gCount + 1
Debug.Print gCount

If gCount > kLIMIT Then
    'MsgBox "Countdown complete."
    ActiveWorkbook.Close True
    Exit Sub
End If
Call Timer
End Sub


Public Sub ResetCount()
gCount = 0
End Sub

Public Sub StartTimer()
ResetCount
ClickTimer
End Sub

When the workbook opens, it starts counting to kLIMIT.
when a user types , it resets to 0.

how about if it should close at let's say 3 minutes of inactivity?? because I tried modifying your code by just changing 30 to 180 but it doesn't work. hoping for your response

 

[gfdwer2]

and in addition, your code will only count if the workbook is not minimized, but if it is minimized, the counting will not work

 

[sergiumirze]

Hi ,

Can you help me ?

I want to autoclose excel after 20 minutes but only if workbook is in read only mode . I also want counting to work even if minimized .


Thx

 

[John_w]

I want to autoclose excel after 20 minutes but only if workbook is in read only mode . I also want counting to work even if minimized .

Put this code in the ThisWorkbook module:

Option Explicit

Private Sub Workbook_Open()
    If Me.ReadOnly Then StartTimer
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If Me.ReadOnly Then StopTimer
End Sub

and this in a standard module (e.g. Module1):

Option Explicit

Public RunWhen As Double
Public Const cRunWhat = "CloseWorkbook"

Public Sub StartTimer()
    RunWhen = Now + TimeValue("00:20:00")
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, Schedule:=True
End Sub

Public Sub CloseWorkbook()
    If Workbooks.Count > 1 Then
        'More than 1 workbook is open so close only this workbook
        ThisWorkbook.Close SaveChanges:=False
    Else
        'Only 1 workbook is open so close the Excel app, which also closes this workbook
        Application.Quit
    End If
End Sub

Public Sub StopTimer()
    On Error Resume Next
    Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, Schedule:=False
End Sub

Save, close and reopen the workbook to test.