Close an unused workbook automaticcly after a specific time

jxb · Apr 19, 2007

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

Legacy 98055 · Oct 29, 2007

Here is Erics code and an download example that I tested. Works good. Paste all of this into ThisWorkbook. Edit the three constants-(Hours, Minutes, and Seconds)-to change your TimeOut time. As it stands, the workbook will close and save after 10 seconds of inactivity...

AutoCloseOnTimeOut.erik.van.geit.zip

<table width="100%" border="1" bgcolor="White" style="filter

rogid:DXImageTransform.Microsoft.Gradient(endColorstr='#C0CFE2', startColorstr='#FFFFFF', gradientType='0');"><tr><TD> Option Explicit

 'edit these three constants
 Private Const Hours As Integer = 0
 Private Const Minutes As Integer = 0
 Private Const Seconds As Integer = 10

 Private when As Variant

 Private Sub Workbook_Open()
 MsgBox "The workbook, " & ThisWorkbook.Name & _
 ", will be closed (saved) if inactive for more then " & Hours & " hours, " _
 & Minutes & " minutes, and " & Seconds & " seconds." _
 , 48, "ACTIVITY"
 time_out (True)
 End Sub

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

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

 Private Sub Workbook_Activate()
 restart
 End Sub

 Private Sub Workbook_BeforeClose(Cancel As Boolean)
 cancel_schedule
 End Sub

 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 + TimeSerial(Hours, Minutes, Seconds)
 Application.OnTime when, "ThisWorkbook.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:="ThisWorkbook.time_out", schedule:=False
 On Error GoTo 0
 End Sub

</td></tr></table><button onclick='document.all("10292007135114970").value=document.all("10292007135114970").value.replace(/ \s\s/g,"");document.all("10292007135114970").value=document.all("10292007135114970").value.replace(/ /g,"");window.clipboardData.setData("Text",document.all("10292007135114970").value);'>Copy to Clipboard</BUTTON><textarea style="position:absolute;visibility:hidden" name="10292007135114970" wrap="virtual">
Option Explicit

'edit these three constants
Private Const Hours As Integer = 0
Private Const Minutes As Integer = 0
Private Const Seconds As Integer = 10

Private when As Variant

Private Sub Workbook_Open()
MsgBox "The workbook, " & ThisWorkbook.Name & _
", will be closed (saved) if inactive for more then " & Hours & " hours, " _
& Minutes & " minutes, and " & Seconds & " seconds." _
, 48, "ACTIVITY"
time_out (True)
End Sub

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

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

Private Sub Workbook_Activate()
restart
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
cancel_schedule
End Sub

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 + TimeSerial(Hours, Minutes, Seconds)
Application.OnTime when, "ThisWorkbook.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:="ThisWorkbook.time_out", schedule:=False
On Error GoTo 0
End Sub
</textarea>

Nyanko · Oct 30, 2007

Many thanks for this it worked a TREAT !

However just one small request ... I have a Msgbox that appears as part of the close process and this holds up the autoclose until the OK button is pressed. Is there anyway to bypass this in the event of the suto close ?

Code:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
 
    'Hides all sheets except Macro Disabled
    'Visable Sheets
    Sheets("Macro Disabled").Visible = xlSheetVisible
    'Hidden Sheets
    Sheets("Control").Visible = xlSheetVeryHidden
    Sheets("Chart").Visible = xlSheetVeryHidden
    Sheets("Entries").Visible = xlSheetVeryHidden

    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("temp").Delete
    Sheets("Comment Listing").Delete
    Call ControlHide
    Application.DisplayAlerts = True

    On Error GoTo Error

    Sheets("Control").Select
    Range("F16").Select
    Sheets("Control").Visible = xlSheetVeryHidden

    cancel_schedule
    
    'normal Save
    If Me.Saved = False Then Me.Save
    MsgBox ("All information has now been saved")
    End

Error:
    MsgBox Prompt:="Please advise administrator of the following message :" & vbCrLf & vbCrLf & "Before Close Error number : " & Err.Number & vbCrLf & Err.Description, Buttons:=vbOKOnly, Title:="Before Close Error"
    Application.CutCopyMode = False
End Sub

Also I have a randomness where the sheet will keep opening and closing after the autoclose. I have no idea why - any help ?

Legacy 98055 · Oct 30, 2007

Sure. Place this in the general declarations section up top...

Private IsAutoClosing As Boolean

Also edit this procedure to allow us to determine if this was a shutdown originating from the auto timeout code...

With ThisWorkbook
cancel_schedule
IsAutoClosing = True
.Close True
End With

Then for your msgbox.
If Not IsAutoClosing Then MsgBox ("All information has now been saved")

Nyanko · Oct 30, 2007

Genius.

ray:
Most appriciated.

I'm still having random problems with the file opening on it's own and closing waaay before it should do.

Please can you advise if I've added this code correctly ? I have a feeling that something isn't quite right :

Code:

Option Explicit
'edit these three constants as part of the auto save/close routine
Private Const Hours As Integer = 2
Private Const Minutes As Integer = 0
Private Const Seconds As Integer = 0
-----------------------------------------------------------------------
Private when As Variant
Private IsAutoClosing As Boolean

Private Sub Workbook_Open()
    'Visable Sheets
    On Error Resume Next
    Sheets("Control").Visible = xlSheetVisible
    Sheets("Chart").Visible = xlSheetVisible
     'Hidden Sheets
    Sheets("Macro Disabled").Visible = xlSheetVeryHidden
 
    Sheets("Control").Select
    Call ControlHide
    Sheets("Control").Select

    On Error GoTo Error

    MsgBox "Use cell drop down menus for data entry as instructions are given for some entries." & vbCrLf & vbCrLf & "BE AWARE" & vbCrLf & "This file will be closed and saved if inactive for more then " & Hours & " hours, and " & Minutes & " minutes", 48, "INFORMATION"
    time_out (True)

    Call CloseProcess    'checks that period haven't ended

    End
Error:
    MsgBox Prompt:="Please advise administrator of the following message :" & vbCrLf & vbCrLf & "On Open Error number : " & Err.Number & vbCrLf & Err.Description, Buttons:=vbOKOnly, Title:="On Open Error"
    Application.CutCopyMode = False
    End

End Sub
-----------------------------------------------------------------------
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    restart
End Sub
-----------------------------------------------------------------------
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    restart
End Sub
-----------------------------------------------------------------------
Private Sub Workbook_Activate()
    restart
End Sub
-----------------------------------------------------------------------
Private Sub Workbook_BeforeClose(Cancel As Boolean)
 
    'Hides all sheets except Macro Disabled
    'Visable Sheets
    Sheets("Macro Disabled").Visible = xlSheetVisible
    'Hidden Sheets
    Sheets("Control").Visible = xlSheetVeryHidden
    Sheets("Chart").Visible = xlSheetVeryHidden
    Sheets("Entries").Visible = xlSheetVeryHidden
 
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("temp").Delete
    Sheets("Comment Listing").Delete
    Call ControlHide
    Application.DisplayAlerts = True

    On Error GoTo Error

    Sheets("Control").Select
    Range("F16").Select
    Sheets("Control").Visible = xlSheetVeryHidden

    cancel_schedule

    'normal Save
    If Me.Saved = False Then Me.Save
    
    If Not IsAutoClosing Then MsgBox ("All information has now been saved")
    End

Error:
    MsgBox Prompt:="Please advise administrator of the following message :" & vbCrLf & vbCrLf & "Before Close Error number : " & Err.Number & vbCrLf & Err.Description, Buttons:=vbOKOnly, Title:="Before Close Error"
    Application.CutCopyMode = False
End Sub
-----------------------------------------------------------------------
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 + TimeSerial(Hours, Minutes, Seconds)
        Application.OnTime when, "ThisWorkbook.time_out"
        Exit Sub
    End If

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

Nyanko · Nov 1, 2007

bump ?

Legacy 98055 · Nov 1, 2007

Nyanko. Sorry. I lost track of your post. I have a procedure that conditionally saves workbooks. Maybe I can adapt it to conditionally close workbooks. I'll get back to your post later today...

Nyanko · Nov 2, 2007

Thank you so much for your time ! You're a star

Legacy 98055 · Nov 2, 2007

Nyanko

This module was created for an application other than Excel. I edited it and it appears to work fine. Download the example and read the notes contained within the code. Let me know if you have any problems...

OnTimePlus.zip

Example usage utilizing workbook open.
<table width="100%" border="1" bgcolor="White" style="filter

rogid:DXImageTransform.Microsoft.Gradient(endColorstr='#C0CFE2', startColorstr='#FFFFFF', gradientType='0');"><tr><TD> Option Explicit

 Private Sub Workbook_Open()
 MsgBox "This workbook will automatically save and close if there are 5 consecutive seconds of inactivity. If this is the only workbook open, Excel will quit as well."
 RunOnTimePlus
 End Sub

 Sub RunOnTimePlus()
 Dim OnTimeArgs As OnTimeArguments
 On Error GoTo Err_Example

 With OnTimeArgs
 .TimeOutOn = OnUserIdle
 .ProcedureName = "ThisWorkbook.TimedOut"
 .CheckIntervalSeconds = 1
 .Seconds = 5
 End With

 StartOnTimePlus OnTimeArgs

 Exit Sub
 Err_Example:
 MsgBox "Error Number: " & Err.Number & vbCrLf & vbCrLf & Err.Description, , Err.Source
 End Sub

 Friend Sub TimedOut()
 If Ok2CloseApp Then
 Me.Save
 Application.Quit
 Else
 Me.Close True
 End If
 End Sub

 Private Function Ok2CloseApp() As Boolean
 Dim wb As Workbook, WBCnt As Integer

 For Each wb In Application.Workbooks
 If wb.Path <> Application.StartupPath Or Not wb.IsAddin Then
 WBCnt = WBCnt + 1
 End If
 Next
 Ok2CloseApp = (WBCnt = 1)
 End Function
</td></tr></table><button onclick='document.all("1122007133945295").value=document.all("1122007133945295").value.replace(/ \s\s/g,"");document.all("1122007133945295").value=document.all("1122007133945295").value.replace(/ /g,"");window.clipboardData.setData("Text",document.all("1122007133945295").value);'>Copy to Clipboard</BUTTON><textarea style="position:absolute;visibility:hidden" name="1122007133945295" wrap="virtual">
Option Explicit

Private Sub Workbook_Open()
MsgBox "This workbook will automatically save and close if there are 5 consecutive seconds of inactivity. If this is the only workbook open, Excel will quit as well."
RunOnTimePlus
End Sub

Sub RunOnTimePlus()
Dim OnTimeArgs As OnTimeArguments
On Error GoTo Err_Example

With OnTimeArgs
.TimeOutOn = OnUserIdle
.ProcedureName = "ThisWorkbook.TimedOut"
.CheckIntervalSeconds = 1
.Seconds = 5
End With

StartOnTimePlus OnTimeArgs

Exit Sub
Err_Example:
MsgBox "Error Number: " & Err.Number & vbCrLf & vbCrLf & Err.Description, , Err.Source
End Sub

Friend Sub TimedOut()
If Ok2CloseApp Then
Me.Save
Application.Quit
Else
Me.Close True
End If
End Sub

Private Function Ok2CloseApp() As Boolean
Dim wb As Workbook, WBCnt As Integer

For Each wb In Application.Workbooks
If wb.Path <> Application.StartupPath Or Not wb.IsAddin Then
WBCnt = WBCnt + 1
End If
Next
Ok2CloseApp = (WBCnt = 1)
End Function</textarea>

In a standard module.
<table width="100%" border="1" bgcolor="White" style="filter

rogid:DXImageTransform.Microsoft.Gradient(endColorstr='#C0CFE2', startColorstr='#FFFFFF', gradientType='0');"><tr><TD> Option Explicit

 'StopOnTimePlus comment it out

 ' to initiate a timeout from another application, use the SetProp API function along with the Desktop's hWnd
 ' Example

 ' Option Explicit
 '
 ' Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
 ' Private Declare Function GetDesktopWindow Lib "user32" () As Long
 '
 ' Sub Example()
 ' SetProp GetDesktopWindow, "OnTimePlus.xls", CLng(True)
 ' End Sub

 ' will fire the timeout in this workbook
 ' the timeout may not occur immediately the delay depends on the value you
 ' assign to OnTimeArguments.CheckIntervalSeconds
 '
 ' order of precedence:
 ' 1. OnTimeOutFromExternal
 ' 2. OnTime
 ' 3. OnWorkBookDeactivation (and/or) OnApplicationDeactivation (and/or) OnUserIdle
 '
 ' the min timeout is 1 second
 '
 ' if argument AtDateTime is assigned a value then OnTimeFlag = True
 '
 ' if OnTimeFlag = True then argument AtDateTime must contain a valid date
 '
 ' OnTimeArguments.CheckIntervalSeconds is the interval the code checks for time out conditions
 '
 ' Each call to OnTimePlus supercedes previous calls
 '
 ' You can call OnTimePlus from your timeout procedure to restart it automatically
 '
 ' OnUserIdle is an application wide notification, not system wide, and
 ' relates to keyboard and mouse activity only
 '
 ' the Function TimedOut() is the default function. I recommend that you assign a valid
 ' procedure name to the OnTimeArguments.ProcedureName arg. This procedure should be
 ' located elsewhere in your project. If it is locted in a public object module such
 ' as a workbook or worksheet class, make sure you qualify it as a member using the codename
 ' "ThisWorkbook.MyProcedure" or "Sheet1.MyProcedure"
 '
 ' TimeOutOn may be any combination of TimeOutType enum values.
 ' Explanations
 '
 ' TimeOutOn = OnTime + OnApplicationDeactivation + OnUserIdle
 ' will time out if...
 ' 1. the application loses focus or is minimized for the amount of time defined in Hours, Minutes, or Seconds or
 ' 2. no user activity is detected for the amount of time defined in Hours, Minutes, or Seconds or
 ' 3. the AtDateTime has been equaled by the system time
 '
 ' TimeOutOn = OnTime
 ' will time out if...
 ' 1. the AtDateTime has been equaled by the system time and is the same as Application.OnTime
 '
 ' TimeOutOn = OnTimeOutFromExternal
 ' will time out if...
 ' 1. simply allows the workbook to be timed out from an another
 ' procedure located within the host application or an external application
 ' OnTimeArguments.CheckIntervalSeconds should be set to a lower value
 '
 ' TimeOutOn = OnTime
 ' will time out if...
 ' 1. the AtDateTime has been equaled by the system time
 '
 ' TimeOutOn = OnApplicationDeactivation + OnWorkBookDeactivation + OnUserIdle + OnTimeOutFromExternal
 ' will time out if...
 ' 1. the application loses focus or is minimized for the amount of time defined in Hours, Minutes, or Seconds or
 ' 2. no user activity is detected for the amount of time defined in Hours, Minutes, or Seconds or
 ' 3. the workbook is deactivated for the amount of time defined in Hours, Minutes, or Seconds or
 ' 4. a timeout command is sent from another source

 Public Enum TimeOutType
 OnTimeOutFromExternal = 1
 OnTime = 2
 OnWorkBookDeactivation = 4
 OnApplicationDeactivation = 8
 OnUserIdle = 16
 End Enum

 Public Type OnTimeArguments
 TimeOutOn As TimeOutType
 AtDateTime As Date
 Hours As Double
 Minutes As Double
 Seconds As Double
 CheckIntervalSeconds As Long
 ProcedureName As String
 End Type

 Private Type LASTINPUTINFO
 cbSize As Long
 dwTime As Long
 End Type

 Private Declare Function GetLastInputInfo Lib "user32.dll" (ByRef plii As LASTINPUTINFO) As Long
 Private Declare Function GetTickCount Lib "kernel32" () As Long
 Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
 Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 Private Declare Function GetForegroundWindow Lib "user32" () As Long
 Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
 Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
 Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
 Private Declare Function GetDesktopWindow Lib "user32" () As Long

 Private Const MAXIMUM_INTERVAL_SECONDS As Long = 86400
 Private Const MINIMUM_INTERVAL_SECONDS As Long = 1

 Private TimerId As Long
 Private TimerCheckIntervalMilliseconds As Long
 Private TimeOutOnTime(1) As Date
 Private TotalSeconds As Double
 Private RunProcedureName As String
 Private OnTimeOutFromExternalFlag As Boolean
 Private OnTimeFlag As Boolean
 Private OnWorkBookDeactivationFlag As Boolean
 Private OnApplicationDeactivationFlag As Boolean
 Private OnUserIdleFlag As Boolean
 Private LastInputTickCount As Long
 Private AppHwnd As Long
 Private OnTimeOutFromExternalPropName As String

 Sub Examples()
 Dim OnTimeArgs As OnTimeArguments
 On Error GoTo Err_Example

 ' 'will shut down the workbook if no activity is detected in 2 hours and 30 minutes
 ' 'or at midnight tommorrow. Whichever comes first. Will check for these conditions
 ' 'every thirty seconds. The procedure named "TimedOut" located in ThisWorkbook will fire
 ' With OnTimeArgs
 ' .TimeOutOn = OnUserIdle + OnTime
 ' .AtDateTime = Date + 1
 ' .ProcedureName = "ThisWorkbook.TimedOut"
 ' .CheckIntervalSeconds = 30
 ' .Hours = 2
 ' .Minutes = 30
 ' End With

 'The procedure named "TimedOut" located in ThisWorkbook will fire if
 'there are 10 seconds of inactivity
 'the workbook will automatically save and close
 With OnTimeArgs
 .TimeOutOn = OnUserIdle
 .ProcedureName = "ThisWorkbook.TimedOut"
 .CheckIntervalSeconds = 1
 .Seconds = 10
 End With

 StartOnTimePlus OnTimeArgs

 Exit Sub
 Err_Example:
 MsgBox "Error Number: " & Err.Number & vbCrLf & vbCrLf & Err.Description, , Err.Source
 End Sub

 Public Function StopOnTimePlus() As Boolean
 StopOnTimePlus = Not (KillTimer(0, TimerId) = 0)
 End Function

 Public Function StartOnTimePlus(Args As OnTimeArguments) As Boolean

 Dim MinimumInterval As Long

 On Error GoTo Err_OnTimePlus

 If Args.TimeOutOn = 0 Then
 Err.Raise 10004, "Sub OnTimePlus", "Argument ""OnTimeArguments.TimeOutOn"" type must contain one or more assignments."
 Exit Function
 End If

 ResetVariables

 If TimerId <> 0 Then
 StopOnTimePlus
 TimerId = 0
 End If

 If Args.CheckIntervalSeconds < MINIMUM_INTERVAL_SECONDS Then Args.CheckIntervalSeconds = MINIMUM_INTERVAL_SECONDS
 If Args.CheckIntervalSeconds > MAXIMUM_INTERVAL_SECONDS Then Args.CheckIntervalSeconds = MAXIMUM_INTERVAL_SECONDS

 OnTimeOutFromExternalFlag = Args.TimeOutOn And OnTimeOutFromExternal
 OnTimeFlag = Args.TimeOutOn And OnTime
 OnWorkBookDeactivationFlag = Args.TimeOutOn And OnWorkBookDeactivation
 OnApplicationDeactivationFlag = Args.TimeOutOn And OnApplicationDeactivation
 OnUserIdleFlag = Args.TimeOutOn And OnUserIdle

 If CDbl(Args.AtDateTime) > 0 Then OnTimeFlag = True

 If OnTimeFlag And Args.AtDateTime < Now Then
 Err.Raise 10000, "Sub OnTimePlus", "Argument ""AtDateTime"" must be greater than the current date and time."
 Exit Function
 ElseIf OnTimeFlag = True Then
 TimeOutOnTime(0) = Args.AtDateTime
 End If

 If (Args.Hours + Args.Minutes + Args.Seconds <= 0) Then Args.Seconds = 1

 TotalSeconds = (Args.Hours * 36000) + (Args.Minutes * 60) + (Args.Seconds)
 TimeOutOnTime(1) = DateAdd("s", TotalSeconds, Now)

 If Not OnTimeFlag Then TimeOutOnTime(0) = TimeOutOnTime(1)

 MinimumInterval = Application.WorksheetFunction.Min(DateDiff("s", Now, TimeOutOnTime(0)), TotalSeconds)
 If MinimumInterval < Args.CheckIntervalSeconds Then Args.CheckIntervalSeconds = Int(MinimumInterval / 10)
 If Args.CheckIntervalSeconds = 0 Then Args.CheckIntervalSeconds = 1

 RunProcedureName = Args.ProcedureName
 AppHwnd = FindWindow("XLMAIN", Application.Caption)

 If OnTimeOutFromExternalFlag Then
 OnTimeOutFromExternalPropName = ThisWorkbook.Name
 SetProp GetDesktopWindow, OnTimeOutFromExternalPropName, CLng(False)
 End If

 TimeOutOnTime(1) = Now
 TimerCheckIntervalMilliseconds = (Args.CheckIntervalSeconds * 800)
 LastInputTickCount = GetTickCount
 ResetTimer
 StartOnTimePlus = True

 Exit Function
 Err_OnTimePlus:
 If Err.Number = 6 Then
 Err.Raise 10002, "Sub OnTimePlus", "Invalid argument."
 ElseIf Err.Number = 10000 Or Err.Number = 10004 Then
 Err.Raise Err.Number, Err.Source, Err.Description
 Exit Function
 Else
 Debug.Print "Unhandled error in Function OnTimePlus" & Err.Number & ", " & Err.Description
 End If
 End Function

 Private Function ResetVariables()
 TimerId = 0
 TimerCheckIntervalMilliseconds = 0
 TimeOutOnTime(0) = 0
 TimeOutOnTime(1) = 0
 TotalSeconds = 0
 RunProcedureName = ""
 OnTimeFlag = False
 OnWorkBookDeactivationFlag = False
 OnApplicationDeactivationFlag = False
 OnUserIdleFlag = False
 RemoveProp GetDesktopWindow, OnTimeOutFromExternalPropName
 End Function

 Function ResetTimer()
 TimerId = SetTimer(0, TimerId, TimerCheckIntervalMilliseconds, AddressOf CheckTimeOutStatus)
 End Function

 Private Function CheckTimeOutStatus(ByVal hwnd As Long, ByVal message As Long, ByVal idTimer As Long, ByVal dwTime As Long)
 On Error GoTo Err_CheckTimeOutStatus

 If CBool(GetProp(GetDesktopWindow, OnTimeOutFromExternalPropName)) Then
 TimedOut
 Exit Function
 End If

 If OnTimeFlag And (Now >= TimeOutOnTime(0)) Then
 TimedOut
 Exit Function
 End If

 If OnApplicationDeactivationFlag Then
 If GetForegroundWindow = AppHwnd And Application.WindowState <> xlMinimized Then
 If Not OnUserIdleFlag Then TimeOutOnTime(1) = Now
 Else
 If HasTimedOut Then
 TimedOut
 Exit Function
 End If
 End If
 End If

 If OnWorkBookDeactivationFlag Then
 If ThisWorkbook Is ActiveWorkbook Then
 TimeOutOnTime(1) = Now
 Else
 If HasTimedOut Then
 TimedOut
 Exit Function
 End If
 End If
 End If

 If OnUserIdleFlag Then
 Dim LastInput As LASTINPUTINFO

 LastInput.cbSize = Len(LastInput)

 If GetLastInputInfo(LastInput) <> 0 Then
 If LastInput.dwTime <> LastInputTickCount Then
 TimeOutOnTime(1) = Now
 Else
 If HasTimedOut Then
 TimedOut
 Exit Function
 End If
 End If
 LastInputTickCount = LastInput.dwTime
 End If
 End If

 Exit Function
 Err_CheckTimeOutStatus:
 StopOnTimePlus
 Debug.Print "Unhandled error in Function CheckTimeOutStatus," & Err.Number & ", " & Err.Description
 End Function

 Private Function HasTimedOut() As Boolean
 If DateDiff("s", TimeOutOnTime(1), Now) >= TotalSeconds Then
 HasTimedOut = True
 End If
 End Function

 Private Function TimedOut()
 On Error Resume Next
 StopOnTimePlus
 If RunProcedureName <> "" Then
 Application.OnTime Now, RunProcedureName
 If Err.Number = 1004 Then
 Err.Raise 10003, "Function TimedOut", Err.Description
 End If
 End If
 ResetVariables
 End Function

</td></tr></table><button onclick='document.all("1122007134033160").value=document.all("1122007134033160").value.replace(/ \s\s/g,"");document.all("1122007134033160").value=document.all("1122007134033160").value.replace(/ /g,"");window.clipboardData.setData("Text",document.all("1122007134033160").value);'>Copy to Clipboard</BUTTON><textarea style="position:absolute;visibility:hidden" name="1122007134033160" wrap="virtual">
Option Explicit

'StopOnTimePlus comment it out

' to initiate a timeout from another application, use the SetProp API function along with the Desktop's hWnd
' Example

' Option Explicit
'
' Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
' Private Declare Function GetDesktopWindow Lib "user32" () As Long
'
' Sub Example()
' SetProp GetDesktopWindow, "OnTimePlus.xls", CLng(True)
' End Sub

' will fire the timeout in this workbook
' the timeout may not occur immediately the delay depends on the value you
' assign to OnTimeArguments.CheckIntervalSeconds
'
' order of precedence:
' 1. OnTimeOutFromExternal
' 2. OnTime
' 3. OnWorkBookDeactivation (and/or) OnApplicationDeactivation (and/or) OnUserIdle
'
' the min timeout is 1 second
'
' if argument AtDateTime is assigned a value then OnTimeFlag = True
'
' if OnTimeFlag = True then argument AtDateTime must contain a valid date
'
' OnTimeArguments.CheckIntervalSeconds is the interval the code checks for time out conditions
'
' Each call to OnTimePlus supercedes previous calls
'
' You can call OnTimePlus from your timeout procedure to restart it automatically
'
' OnUserIdle is an application wide notification, not system wide, and
' relates to keyboard and mouse activity only
'
' the Function TimedOut() is the default function. I recommend that you assign a valid
' procedure name to the OnTimeArguments.ProcedureName arg. This procedure should be
' located elsewhere in your project. If it is locted in a public object module such
' as a workbook or worksheet class, make sure you qualify it as a member using the codename
' "ThisWorkbook.MyProcedure" or "Sheet1.MyProcedure"
'
' TimeOutOn may be any combination of TimeOutType enum values.
' Explanations
'
' TimeOutOn = OnTime + OnApplicationDeactivation + OnUserIdle
' will time out if...
' 1. the application loses focus or is minimized for the amount of time defined in Hours, Minutes, or Seconds or
' 2. no user activity is detected for the amount of time defined in Hours, Minutes, or Seconds or
' 3. the AtDateTime has been equaled by the system time
'
' TimeOutOn = OnTime
' will time out if...
' 1. the AtDateTime has been equaled by the system time and is the same as Application.OnTime
'
' TimeOutOn = OnTimeOutFromExternal
' will time out if...
' 1. simply allows the workbook to be timed out from an another
' procedure located within the host application or an external application
' OnTimeArguments.CheckIntervalSeconds should be set to a lower value
'
' TimeOutOn = OnTime
' will time out if...
' 1. the AtDateTime has been equaled by the system time
'
' TimeOutOn = OnApplicationDeactivation + OnWorkBookDeactivation + OnUserIdle + OnTimeOutFromExternal
' will time out if...
' 1. the application loses focus or is minimized for the amount of time defined in Hours, Minutes, or Seconds or
' 2. no user activity is detected for the amount of time defined in Hours, Minutes, or Seconds or
' 3. the workbook is deactivated for the amount of time defined in Hours, Minutes, or Seconds or
' 4. a timeout command is sent from another source

Public Enum TimeOutType
OnTimeOutFromExternal = 1
OnTime = 2
OnWorkBookDeactivation = 4
OnApplicationDeactivation = 8
OnUserIdle = 16
End Enum

Public Type OnTimeArguments
TimeOutOn As TimeOutType
AtDateTime As Date
Hours As Double
Minutes As Double
Seconds As Double
CheckIntervalSeconds As Long
ProcedureName As String
End Type

Private Type LASTINPUTINFO
cbSize As Long
dwTime As Long
End Type

Private Declare Function GetLastInputInfo Lib "user32.dll" (ByRef plii As LASTINPUTINFO) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Const MAXIMUM_INTERVAL_SECONDS As Long = 86400
Private Const MINIMUM_INTERVAL_SECONDS As Long = 1

Private TimerId As Long
Private TimerCheckIntervalMilliseconds As Long
Private TimeOutOnTime(1) As Date
Private TotalSeconds As Double
Private RunProcedureName As String
Private OnTimeOutFromExternalFlag As Boolean
Private OnTimeFlag As Boolean
Private OnWorkBookDeactivationFlag As Boolean
Private OnApplicationDeactivationFlag As Boolean
Private OnUserIdleFlag As Boolean
Private LastInputTickCount As Long
Private AppHwnd As Long
Private OnTimeOutFromExternalPropName As String

Sub Examples()
Dim OnTimeArgs As OnTimeArguments
On Error GoTo Err_Example

' 'will shut down the workbook if no activity is detected in 2 hours and 30 minutes
' 'or at midnight tommorrow. Whichever comes first. Will check for these conditions
' 'every thirty seconds. The procedure named "TimedOut" located in ThisWorkbook will fire
' With OnTimeArgs
' .TimeOutOn = OnUserIdle + OnTime
' .AtDateTime = Date + 1
' .ProcedureName = "ThisWorkbook.TimedOut"
' .CheckIntervalSeconds = 30
' .Hours = 2
' .Minutes = 30
' End With

'The procedure named "TimedOut" located in ThisWorkbook will fire if
'there are 10 seconds of inactivity
'the workbook will automatically save and close
With OnTimeArgs
.TimeOutOn = OnUserIdle
.ProcedureName = "ThisWorkbook.TimedOut"
.CheckIntervalSeconds = 1
.Seconds = 10
End With

StartOnTimePlus OnTimeArgs

Exit Sub
Err_Example:
MsgBox "Error Number: " & Err.Number & vbCrLf & vbCrLf & Err.Description, , Err.Source
End Sub

Public Function StopOnTimePlus() As Boolean
StopOnTimePlus = Not (KillTimer(0, TimerId) = 0)
End Function

Public Function StartOnTimePlus(Args As OnTimeArguments) As Boolean

Dim MinimumInterval As Long

On Error GoTo Err_OnTimePlus

If Args.TimeOutOn = 0 Then
Err.Raise 10004, "Sub OnTimePlus", "Argument ""OnTimeArguments.TimeOutOn"" type must contain one or more assignments."
Exit Function
End If

ResetVariables

If TimerId <> 0 Then
StopOnTimePlus
TimerId = 0
End If

If Args.CheckIntervalSeconds < MINIMUM_INTERVAL_SECONDS Then Args.CheckIntervalSeconds = MINIMUM_INTERVAL_SECONDS
If Args.CheckIntervalSeconds > MAXIMUM_INTERVAL_SECONDS Then Args.CheckIntervalSeconds = MAXIMUM_INTERVAL_SECONDS

OnTimeOutFromExternalFlag = Args.TimeOutOn And OnTimeOutFromExternal
OnTimeFlag = Args.TimeOutOn And OnTime
OnWorkBookDeactivationFlag = Args.TimeOutOn And OnWorkBookDeactivation
OnApplicationDeactivationFlag = Args.TimeOutOn And OnApplicationDeactivation
OnUserIdleFlag = Args.TimeOutOn And OnUserIdle

If CDbl(Args.AtDateTime) > 0 Then OnTimeFlag = True

If OnTimeFlag And Args.AtDateTime < Now Then
Err.Raise 10000, "Sub OnTimePlus", "Argument ""AtDateTime"" must be greater than the current date and time."
Exit Function
ElseIf OnTimeFlag = True Then
TimeOutOnTime(0) = Args.AtDateTime
End If

If (Args.Hours + Args.Minutes + Args.Seconds <= 0) Then Args.Seconds = 1

TotalSeconds = (Args.Hours * 36000) + (Args.Minutes * 60) + (Args.Seconds)
TimeOutOnTime(1) = DateAdd("s", TotalSeconds, Now)

If Not OnTimeFlag Then TimeOutOnTime(0) = TimeOutOnTime(1)

MinimumInterval = Application.WorksheetFunction.Min(DateDiff("s", Now, TimeOutOnTime(0)), TotalSeconds)
If MinimumInterval < Args.CheckIntervalSeconds Then Args.CheckIntervalSeconds = Int(MinimumInterval / 10)
If Args.CheckIntervalSeconds = 0 Then Args.CheckIntervalSeconds = 1

RunProcedureName = Args.ProcedureName
AppHwnd = FindWindow("XLMAIN", Application.Caption)

If OnTimeOutFromExternalFlag Then
OnTimeOutFromExternalPropName = ThisWorkbook.Name
SetProp GetDesktopWindow, OnTimeOutFromExternalPropName, CLng(False)
End If

TimeOutOnTime(1) = Now
TimerCheckIntervalMilliseconds = (Args.CheckIntervalSeconds * 800)
LastInputTickCount = GetTickCount
ResetTimer
StartOnTimePlus = True

Exit Function
Err_OnTimePlus:
If Err.Number = 6 Then
Err.Raise 10002, "Sub OnTimePlus", "Invalid argument."
ElseIf Err.Number = 10000 Or Err.Number = 10004 Then
Err.Raise Err.Number, Err.Source, Err.Description
Exit Function
Else
Debug.Print "Unhandled error in Function OnTimePlus" & Err.Number & ", " & Err.Description
End If
End Function

Private Function ResetVariables()
TimerId = 0
TimerCheckIntervalMilliseconds = 0
TimeOutOnTime(0) = 0
TimeOutOnTime(1) = 0
TotalSeconds = 0
RunProcedureName = ""
OnTimeFlag = False
OnWorkBookDeactivationFlag = False
OnApplicationDeactivationFlag = False
OnUserIdleFlag = False
RemoveProp GetDesktopWindow, OnTimeOutFromExternalPropName
End Function

Function ResetTimer()
TimerId = SetTimer(0, TimerId, TimerCheckIntervalMilliseconds, AddressOf CheckTimeOutStatus)
End Function

Private Function CheckTimeOutStatus(ByVal hwnd As Long, ByVal message As Long, ByVal idTimer As Long, ByVal dwTime As Long)
On Error GoTo Err_CheckTimeOutStatus

If CBool(GetProp(GetDesktopWindow, OnTimeOutFromExternalPropName)) Then
TimedOut
Exit Function
End If

If OnTimeFlag And (Now >= TimeOutOnTime(0)) Then
TimedOut
Exit Function
End If

If OnApplicationDeactivationFlag Then
If GetForegroundWindow = AppHwnd And Application.WindowState <> xlMinimized Then
If Not OnUserIdleFlag Then TimeOutOnTime(1) = Now
Else
If HasTimedOut Then
TimedOut
Exit Function
End If
End If
End If

If OnWorkBookDeactivationFlag Then
If ThisWorkbook Is ActiveWorkbook Then
TimeOutOnTime(1) = Now
Else
If HasTimedOut Then
TimedOut
Exit Function
End If
End If
End If

If OnUserIdleFlag Then
Dim LastInput As LASTINPUTINFO

LastInput.cbSize = Len(LastInput)

If GetLastInputInfo(LastInput) <> 0 Then
If LastInput.dwTime <> LastInputTickCount Then
TimeOutOnTime(1) = Now
Else
If HasTimedOut Then
TimedOut
Exit Function
End If
End If
LastInputTickCount = LastInput.dwTime
End If
End If

Exit Function
Err_CheckTimeOutStatus:
StopOnTimePlus
Debug.Print "Unhandled error in Function CheckTimeOutStatus," & Err.Number & ", " & Err.Description
End Function

Private Function HasTimedOut() As Boolean
If DateDiff("s", TimeOutOnTime(1), Now) >= TotalSeconds Then
HasTimedOut = True
End If
End Function

Private Function TimedOut()
On Error Resume Next
StopOnTimePlus
If RunProcedureName <> "" Then
Application.OnTime Now, RunProcedureName
If Err.Number = 1004 Then
Err.Raise 10003, "Function TimedOut", Err.Description
End If
End If
ResetVariables
End Function
</textarea>

abinash1788 · Apr 11, 2018

Tom Schreiner said:
Here is Erics code and an download example that I tested. Works good. Paste all of this into ThisWorkbook. Edit the three constants-(Hours, Minutes, and Seconds)-to change your TimeOut time. As it stands, the workbook will close and save after 10 seconds of inactivity...

AutoCloseOnTimeOut.erik.van.geit.zip

[TABLE="width: 100%"]
<tbody>[TR]
[TD] Option Explicit

'edit these three constants
Private Const Hours As Integer = 0
Private Const Minutes As Integer = 0
Private Const Seconds As Integer = 10

Private when As Variant

Private Sub Workbook_Open()
MsgBox "The workbook, " & ThisWorkbook.Name & _
", will be closed (saved) if inactive for more then " & Hours & " hours, " _
& Minutes & " minutes, and " & Seconds & " seconds." _
, 48, "ACTIVITY"
time_out (True)
End Sub

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

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

Private Sub Workbook_Activate()
restart
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
cancel_schedule
End Sub

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 + TimeSerial(Hours, Minutes, Seconds)
Application.OnTime when, "ThisWorkbook.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:="ThisWorkbook.time_out", schedule:=False
On Error GoTo 0
End Sub
[/TD]
[/TR]
</tbody>[/TABLE]
Thanks for. the code it works correctly but can you help me in modifying . In my worksheet if I enter data on Column "I" then time stamp occurs at column "K". Then I subtract time value from each row to get on column "J". So when excel closes if it enter "idle" on column "I" to identify activity then it will be great.

Close an unused workbook automaticcly after a specific time

jxb

Board Regular

Legacy 98055

Guest

Excel Facts

Nyanko

Active Member

Legacy 98055

Guest

Nyanko

Active Member

Nyanko

Active Member

Legacy 98055

Guest

Nyanko

Active Member

Legacy 98055

Guest

abinash1788

New Member

Similar threads

Forum statistics

Share this page

Close an unused workbook automaticcly after a specific time

jxb

Board Regular

Legacy 98055

Guest

Excel Facts

Nyanko

Active Member

Legacy 98055

Guest

Nyanko

Active Member

Nyanko

Active Member

Legacy 98055

Guest

Nyanko

Active Member

Legacy 98055

Guest

abinash1788

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock