Auto shutdown code not executing

Malciberg · Nov 20, 2007

Good day everyone

I have a workbook which autosaves and closes if no data is input for 10 minutes. It resides on a drive accessable by all our team and is set so that only one person can have read/ wrote access at a time. It tests for read only, shuts down if it is and saves and shuts down if not.

I have noticed that it doesn't work if the workbook is waiting for input.

I.e. someone starts to enter text, or something, in a cell, then goes off to make a coffee or whatever leaving the entry cursor sitting there blinking. It will not shut down after the ten minutes with no input.

Can anyone point me in the right direction on this?

I will happily post my code if somebody can tell me how!! I don't want to commit a faux pas

regards to all

Malcolm

Andrew Poulsom · Nov 20, 2007

I don't think that's possible, because Excel is modal during data entry and any code you have won't run until the entry is completed.

Malciberg · Nov 20, 2007

Auto shut down not executing

Thanks for the prompt reply. At least I know it can't be done

regards

Malcolm

Legacy 98055 · Nov 20, 2007

"I have noticed that it doesn't work if the workbook is waiting for input."

I suppose that you mean Excel is in edit mode? For example, double-clicking a cell usually places Excel in edit mode...

"At least I know it can't be done..."

Sure it can. Pease post your code.

Coaxing Excel out of edit mode is not a problem. However, another scenario that will cause you the same problem are modal dialogs. These can be dealt with as well but it might involve some fair amount of code.

Malciberg · Nov 21, 2007

Hi Tom

By waiting for input I mean for instance someone starts writing text or numbers in a cell and then leaves it to do something else and when you look at the cell you see the input text and a cursor flashing waiting for more input or someone to press enter. My code doesnt work under those circumstances.

My code: In This Workbook

Code:

Option Explicit
Private Sub Workbook_Open()
MsgBox "This workbook will auto-save and close if left unused for 10 minutes ", vbCritical, "Warning"
    start_Countdown
    End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    stop_Countdown
    start_Countdown
    End Sub

and in module 1

Code:

Option Explicit
Public Close_Time As Date
Sub start_Countdown()
    Close_Time = Now() + TimeValue("00:10:00")
    Application.OnTime Close_Time, "close_WB"
    End Sub
Sub stop_Countdown()
    Application.OnTime Close_Time, "close_WB", , False
    End Sub
Sub close_wb()
    If ActiveWorkbook.ReadOnly Then
    ThisWorkbook.Saved = True 'If opened by a read-only user, reports that changes have already been saved
    ThisWorkbook.Close 'then closes the workbook without saving/updating
    Else
    ThisWorkbook.Save
    ThisWorkbook.Close True
    End If
    End Sub

Hope that all makes sense

regards

Malcolm

Legacy 98055 · Nov 21, 2007

See notes in code... Let me know if editmode gives you any trouble. This is a new addition of logic that I had not incorporated before; it has been lightly tested at best...

Download: Malciberg.1456186.xls.zip

In the workbook class:
<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 auto-save and close if left unused for 10 minutes ", vbCritical, "Warning"

 MsgBox "Sub close_wb will run if idle for about five seconds", vbCritical, "Warning"
 ' will run "Sub close_wb" if there is no mouse or keyboard activity for three consecutive seconds
 ' will check for this condition once per second
 StartIdleTimeOutNotification _
 Seconds:=5, _
 CheckIntervalSeconds:=1, _
 RunProcedureName:=Me.CodeName & ".close_wb"

 ' this example will run "Sub close_wb" if there is no mouse or keyboard activity for
 ' ten consecutive minutes. Note that the interval you choose will come with a variance
 ' which is probably insignificant in your case. For example, with a CheckIntervalSeconds:=10
 ' seconds, Sub close_wb may not actually run until there is 10 minutes and 9 seconds of idleness

 ' StartIdleTimeOutNotification _
 ' Minutes:=10, _
 ' CheckIntervalSeconds:=10, _
 ' RunProcedureName:=Me.CodeName & ".close_wb"

 ' the Hours, Minutes, Seconds arguments are not based upon any standard
 ' for example, passing (Minutes:=90) alone or both (Hours:=1, Minutes:=30) would yield the same results

 ' this is a message board post adapted from another much more comprehensive autoshutdown method
 ' it is not developer friendly
 ' you will need to use common sense such as making sure the CheckIntervalSeconds < TotalSeconds
 ' call StopIdleTimeOutNotification at any time to stop the timer
 End Sub

 Private Sub Workbook_BeforeClose(Cancel As Boolean)
 StopIdleTimeOutNotification
 End Sub

 Sub close_wb()
 MsgBox "close_wb is running..."
 ' If Me.ReadOnly Then
 ' Me.Saved = True 'If opened by a read-only user, reports that changes have already been saved
 ' Me.Close 'then closes the workbook without saving/updating
 ' Else
 ' Me.Close True
 ' End If
 End Sub

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

Private Sub Workbook_Open()
' MsgBox "This workbook will auto-save and close if left unused for 10 minutes ", vbCritical, "Warning"

MsgBox "Sub close_wb will run if idle for about five seconds", vbCritical, "Warning"
' will run "Sub close_wb" if there is no mouse or keyboard activity for three consecutive seconds
' will check for this condition once per second
StartIdleTimeOutNotification _
Seconds:=5, _
CheckIntervalSeconds:=1, _
RunProcedureName:=Me.CodeName & ".close_wb"

' this example will run "Sub close_wb" if there is no mouse or keyboard activity for
' ten consecutive minutes. Note that the interval you choose will come with a variance
' which is probably insignificant in your case. For example, with a CheckIntervalSeconds:=10
' seconds, Sub close_wb may not actually run until there is 10 minutes and 9 seconds of idleness

' StartIdleTimeOutNotification _
' Minutes:=10, _
' CheckIntervalSeconds:=10, _
' RunProcedureName:=Me.CodeName & ".close_wb"

' the Hours, Minutes, Seconds arguments are not based upon any standard
' for example, passing (Minutes:=90) alone or both (Hours:=1, Minutes:=30) would yield the same results

' this is a message board post adapted from another much more comprehensive autoshutdown method
' it is not developer friendly
' you will need to use common sense such as making sure the CheckIntervalSeconds < TotalSeconds
' call StopIdleTimeOutNotification at any time to stop the timer
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
StopIdleTimeOutNotification
End Sub

Sub close_wb()
MsgBox "close_wb is running..."
' If Me.ReadOnly Then
' Me.Saved = True 'If opened by a read-only user, reports that changes have already been saved
' Me.Close 'then closes the workbook without saving/updating
' Else
' Me.Close True
' End If
End Sub
</textarea>

In a standard module (this is a must for the two callback procedures):<table width="100%" border="1" bgcolor="White" style="filter

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

 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 Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

 Private Const KEYEVENTF_KEYUP = &H2

 Private LastInputTickCount As Long
 Private TimerId As Long
 Private TimeOutOnTime As Date
 Private TimeOutSeconds As Long
 Private RunProcedure As String

 Public Function StartIdleTimeOutNotification( _
 Optional Hours As Long = 0, _
 Optional Minutes As Long = 0, _
 Optional Seconds As Long = 0, _
 Optional CheckIntervalSeconds As Long = 1, _
 Optional RunProcedureName As String = "")

 CheckIntervalSeconds = (CheckIntervalSeconds * 1000#)
 'max CheckIntervalSeconds = one day or 86400 seconds
 If CheckIntervalSeconds > 86400 Then CheckIntervalSeconds = 86400
 RunProcedure = RunProcedureName
 TimeOutSeconds = Seconds + (Minutes * 60#) + (Hours * 3600#)

 TimerId = SetTimer(0, TimerId, CheckIntervalSeconds, AddressOf CheckTimeOutStatus)
 LastInputTickCount = GetTickCount
 End Function

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

 Private Function CheckTimeOutStatus(ByVal hwnd As Long, ByVal message As Long, ByVal idTimer As Long, ByVal dwTime As Long)
 Dim LastInput As LASTINPUTINFO

 On Error Resume Next

 LastInput.cbSize = Len(LastInput)

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

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

 Private Function TimedOut()
 Dim ExcelInEditMode As Boolean
 On Error Resume Next

 StopIdleTimeOutNotification

 TimerId = SetTimer(0, TimerId, 100, AddressOf RunNamedProcedure)

 'returns true if Excel is in edit mode
 ExcelInEditMode = (Not Application.CommandBars.FindControl(ID:=23).Enabled)

 If ExcelInEditMode Then
 keybd_event vbKeyLeft, 0, 0, 0
 keybd_event vbKeyLeft, 0, KEYEVENTF_KEYUP, 0
 End If
 End Function

 Private Function RunNamedProcedure(ByVal hwnd As Long, ByVal message As Long, ByVal idTimer As Long, ByVal dwTime As Long)
 On Error Resume Next

 StopIdleTimeOutNotification

 If RunProcedure <> "" Then
 Application.OnTime Now, RunProcedure
 Else
 'place your code here if you have not provided a procedure to run
 MsgBox "TimedOut"
 End If
 End Function

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

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 Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const KEYEVENTF_KEYUP = &H2

Private LastInputTickCount As Long
Private TimerId As Long
Private TimeOutOnTime As Date
Private TimeOutSeconds As Long
Private RunProcedure As String

Public Function StartIdleTimeOutNotification( _
Optional Hours As Long = 0, _
Optional Minutes As Long = 0, _
Optional Seconds As Long = 0, _
Optional CheckIntervalSeconds As Long = 1, _
Optional RunProcedureName As String = "")

CheckIntervalSeconds = (CheckIntervalSeconds * 1000#)
'max CheckIntervalSeconds = one day or 86400 seconds
If CheckIntervalSeconds > 86400 Then CheckIntervalSeconds = 86400
RunProcedure = RunProcedureName
TimeOutSeconds = Seconds + (Minutes * 60#) + (Hours * 3600#)

TimerId = SetTimer(0, TimerId, CheckIntervalSeconds, AddressOf CheckTimeOutStatus)
LastInputTickCount = GetTickCount
End Function

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

Private Function CheckTimeOutStatus(ByVal hwnd As Long, ByVal message As Long, ByVal idTimer As Long, ByVal dwTime As Long)
Dim LastInput As LASTINPUTINFO

On Error Resume Next

LastInput.cbSize = Len(LastInput)

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

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

Private Function TimedOut()
Dim ExcelInEditMode As Boolean
On Error Resume Next

StopIdleTimeOutNotification

TimerId = SetTimer(0, TimerId, 100, AddressOf RunNamedProcedure)

'returns true if Excel is in edit mode
ExcelInEditMode = (Not Application.CommandBars.FindControl(ID:=23).Enabled)

If ExcelInEditMode Then
keybd_event vbKeyLeft, 0, 0, 0
keybd_event vbKeyLeft, 0, KEYEVENTF_KEYUP, 0
End If
End Function

Private Function RunNamedProcedure(ByVal hwnd As Long, ByVal message As Long, ByVal idTimer As Long, ByVal dwTime As Long)
On Error Resume Next

StopIdleTimeOutNotification

If RunProcedure <> "" Then
Application.OnTime Now, RunProcedure
Else
'place your code here if you have not provided a procedure to run
MsgBox "TimedOut"
End If
End Function

</textarea>

GlennUK · Nov 22, 2007

That's very nice Right_Click, but wouldn't it be better to use vbKeyReturn instead of vbKeyLeft? If the user is in Edit Mode in column A won't vbKeyLeft fail to exit Edit Mode?

Legacy 98055 · Nov 22, 2007

No. A vbKeyeft in column A will exit edit mode. The reason I used the Left key was because it seemed to risky to haphazardly send an Enter without knowing what it might do. It is the default keypress for many windows. Know what I mean?

GlennUK · Nov 22, 2007

No. A vbKeyeft in column A will exit edit mode. The reason I used the Left key was because it seemed to risky to haphazardly send an Enter without knowing what it might do. It is the default keypress for many windows. Know what I mean?

Yes, know what you mean.

I must have been doing something different to stop it working. Will try more experiments. Hope the OP is as impressed as I am.

Malciberg · Nov 23, 2007

Thanks Tom

I am not at work at present, hence the delay in replying, so can't try it out but thanks for the code you must have put an enourmous amount of work into that.

Will try it out when I get back to work on Monday and thanks once again.

I am now going to try and understand what it all means as you will no doubt have gathered i am pretty new to this.

regards

Malcolm

Auto shutdown code not executing

Malciberg

New Member

Excel Facts

Andrew Poulsom

MrExcel MVP

Malciberg

New Member

Legacy 98055

Guest

Malciberg

New Member

Legacy 98055

Guest

GlennUK

Well-known Member

Legacy 98055

Guest

GlennUK

Well-known Member

Malciberg

New Member

Similar threads

Forum statistics

Share this page

Auto shutdown code not executing

Malciberg

New Member

Excel Facts

Andrew Poulsom

MrExcel MVP

Malciberg

New Member

Legacy 98055

Guest

Malciberg

New Member

Legacy 98055

Guest

GlennUK

Well-known Member

Legacy 98055

Guest

GlennUK

Well-known Member

Malciberg

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