Help with a closing WB w/o activity!

**jose luis** · 04-08-2005, 08:49 PM

Hi Community

I found this post sometime ago, I am trying to acomplish the same but it seems not to run properly. The Disable Sub is not working. It doesn't matter if i select or click always closes the app at the time calculated in the start. Any help to arrange this.

Thank you

Jose Luis

POST FOUND:

"What I would like to do is if there has been no activity on the workbook
for 10 minutes it will save and close automatically. Any pointers most appreciated.
Taffy"

Taffy, here is a macro that will do it, I don't remember who wrote it, maybe
somebody will see it and let me know who to give credit to.
As is it will save and then close the workbook after 20 seconds of
inactivity, use to test then change the 20 seconds to your time

Paul B
Always backup your data before trying something new
Please post any response to the newsgroups so others can benefit from it
Feedback on answers is always appreciated!

**** these in "ThisWorkbook"
Private Sub Workbook_Open()
MsgBox "This workbook will auto-close after 30 seconds of inactivity"
Call SetTime
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call Disable
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Call Disable
Call SetTime
End Sub

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Call Disable
Call SetTime
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Call Disable
Call SetTime
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
Call Disable
Call SetTime
End Sub

*** these in a module
Sub SetTime()
Dim DownTime As Date
DownTime = Now + TimeValue("00:00:50") 'change time as needed
Application.OnTime DownTime, "ShutDown"
End Sub

Sub ShutDown()
'MsgBox "El sistema se cerrara por inactividad", vbExclamation
ThisWorkbook.Save
ThisWorkbook.Close
End Sub

Sub Disable()
On Error Resume Next
Application.OnTime EarliestTime:=DownTime, Procedure:="ShutDown", Schedule:=False
End Sub

**chris100** · 04-01-2006, 07:03 AM

Hi all,

I was trying the procedure below, but it continually saves, closes then reopens and goes through the same process again.

I tried messing around with a few things and i know you have to stop the ontimer thing but i had no luck.
If anyone could find the problem in this procedure i would appreciate it because this auto close with be handy.

Thanks in advance,

Chris

Greg Wilson · 04-02-2006, 12:00 AM

Try declaring DownTime at the top of the module instead of within the SetTime
procedure. If declared inside the SetTime procedure, its value is not
available to the Disable procedure. Therefore, the Disable procedure fails to
find a scheduled event for ShutDown since it always gets the scheduled time
wrong. Maybe that's why the On Error Resume Next is used.

If I were to write this, I think I would go with monitoring the mouse
pointer position using GetCursorPos (API code) instead of having VBA monitor
all those events. Just my $0.02 worth.

Regards,
Greg

**chris100** · 04-02-2006, 02:03 PM

Thanks Greg,

I did what you suggested and it seemed to solve the problem fine. I would ttry your other method but at the mo i'm still learning so have to plagarise and beg for help a lot of the time.

thanks again for your $0.02. Helped a lot.

chris

**chris100** · 04-02-2006, 05:21 PM

Greg,

Do you think this is possible. I've put a msgbox in the sub shutdown to confirm closure, but what i really would like is a msgbox telling the user that the program will close if they do not cancel:

Sub ShutDown()
Answer = MsgBox("Inactivity Detected, program will shutdown in 20 seconds unless cancelled. Do you want to quit?", vbYesNo)
If Answer = vbNo Then Exit Sub
ThisWorkbook.Save
ThisWorkbook.Close
End Sub

How could you put a timer in so that it will close after 20 seconds?

Answers on a postcard....

Greg Wilson · 04-03-2006, 04:10 AM

Chris,

The problem with using a message box is that, unlike a userform, no VBA
macro can execute while it is open. Someone must manually close it. So, this
defeats the whole point of the auto-close, which is designed to close the wb
if it is unattended. You can't use, for example, Application.Sendkeys to
programmatically close the message box after a number of seconds if there is
no response. And there is no code to my knowledge that can get around this
except perhaps for API code that I am not familiar with. (This is all just my
opinion and I admit I may be missing something).

Instead, I suggest the appended code which creates a toolbar on wb_open and
which supports the following buttons:
1. "Continue Working"
2. "Close Now"
3. "Disable"

If there is no response after the toolbar is displayed then the wb will
close in 10 seconds.

Also, note that I dispenced with the VBA event code used to monitor activity
and instead rely on monitoring the exact position of the mouse pointer. If
its x- and y-coordinates change between checks then it will suppress display
of the toolbar and will just reset the time of the next check (i.e. execute
the SetTime macro).

This is not a polished product, just something I came up with in response to
your post. It will likely have some flaws. The 1440 figure is the number of
minutes in a day. So 10 (the set wait time in minutes) divided by this figure
gives the correct fraction of a day. Change the value of the public constant
WaitTime to suit.

'xxxxxxxx Paste to the ThisWorkbook module xxxxxxxx

Private Sub Workbook_Open()
Dim msg As String
msg = "This workbook will auto-close after " & WaitSecs & _
" seconds of inactivity. "
MsgBox msg, vbInformation, "Auto-Close"
Call MakeToolBar
Call SetTime
End Sub

'xxxxxxxx Paste to a standard module xxxxxxxx

Option Explicit
Public Const WaitTime As Single = 10
Public KillTime As Date
Private Type POINTAPI
X As Long
Y As Long
End Type
Dim CursPos As POINTAPI
Private Declare Function GetCursorPos _
Lib "user32" (lpPoint As POINTAPI) As Long

Sub SetTime()
KillTime = Now + WaitTime / 1440
Application.OnTime KillTime, "TestForShutDown"
GetCursorPos CursPos
End Sub

Sub TestForShutDown()
Dim CP As POINTAPI
GetCursorPos CP
If CursPos.X = CP.X And CursPos.Y = CP.Y Then
With Application
.CommandBars("AutoClose").Visible = True
KillTime = Now + 10 / 1440
.OnTime KillTime, "Kill"
End With
Else
Call SetTime
End If
End Sub

Sub ContinueWorking()
With Application
.CommandBars("AutoClose").Visible = False
.OnTime KillTime, "Kill", Schedule:=False
End With
Call SetTime
End Sub

Sub Kill()
With Application
.CommandBars("AutoClose").Delete
If Now < KillTime Then .OnTime KillTime, "Kill", Schedule:=False
End With
ThisWorkbook.Close True
End Sub

Sub Disable()
With Application
.CommandBars("AutoClose").Visible = False
If Now < KillTime Then .OnTime KillTime, "Kill", Schedule:=False
End With
End Sub

Sub MakeToolBar()
Dim CB As CommandBar
Dim Btn As CommandBarButton
Dim i As Integer
Dim arr As Variant, arr2 As Variant

With Application
.ScreenUpdating = False
On Error Resume Next
.CommandBars("AutoClose").Delete
On Error GoTo 0
Set CB = .CommandBars.Add("AutoClose", Temporary:=True)
End With
arr = Array("Continue Working", "Close Now", "Disable")
arr2 = Array("ContinueWorking", "Kill", "Disable")
For i = 0 To 2
Set Btn = CB.Controls.Add
With Btn
.Caption = arr(i)
.OnAction = arr2(i)
.Style = msoButtonCaption
.BeginGroup = (i > 0)
End With
Next
Application.ScreenUpdating = True
CB.Visible = False
End Sub

Best regards,
Greg

Greg Wilson · 04-03-2006, 04:20 AM

When I changed the wait time from seconds to minutes I made a mistake. In
procedure TestForShutDown, change the line

KillTime = Now + 10 / 1440

to

KillTime = Now + 0.1 / 1440

Also change "seconds" to "minutes" in the workbook_open message.

Regards,
Greg

Greg Wilson · 04-03-2006, 04:30 AM

Also change the "WaitSecs" variable to "WaitTime" in the workbook_open
message. I thought I'd fixed that one.

Greg

"Greg Wilson" wrote:

> Chris,
>
> The problem with using a message box is that, unlike a userform, no VBA
> macro can execute while it is open. Someone must manually close it. So, this
> defeats the whole point of the auto-close, which is designed to close the wb
> if it is unattended. You can't use, for example, Application.Sendkeys to
> programmatically close the message box after a number of seconds if there is
> no response. And there is no code to my knowledge that can get around this
> except perhaps for API code that I am not familiar with. (This is all just my
> opinion and I admit I may be missing something).
>
> Instead, I suggest the appended code which creates a toolbar on wb_open and
> which supports the following buttons:
> 1. "Continue Working"
> 2. "Close Now"
> 3. "Disable"
>
> If there is no response after the toolbar is displayed then the wb will
> close in 10 seconds.
>
> Also, note that I dispenced with the VBA event code used to monitor activity
> and instead rely on monitoring the exact position of the mouse pointer. If
> its x- and y-coordinates change between checks then it will suppress display
> of the toolbar and will just reset the time of the next check (i.e. execute
> the SetTime macro).
>
> This is not a polished product, just something I came up with in response to
> your post. It will likely have some flaws. The 1440 figure is the number of
> minutes in a day. So 10 (the set wait time in minutes) divided by this figure
> gives the correct fraction of a day. Change the value of the public constant
> WaitTime to suit.
>
> 'xxxxxxxx Paste to the ThisWorkbook module xxxxxxxx
>
> Private Sub Workbook_Open()
> Dim msg As String
> msg = "This workbook will auto-close after " & WaitSecs & _
> " seconds of inactivity. "
> MsgBox msg, vbInformation, "Auto-Close"
> Call MakeToolBar
> Call SetTime
> End Sub
>
> 'xxxxxxxx Paste to a standard module xxxxxxxx
>
> Option Explicit
> Public Const WaitTime As Single = 10
> Public KillTime As Date
> Private Type POINTAPI
> X As Long
> Y As Long
> End Type
> Dim CursPos As POINTAPI
> Private Declare Function GetCursorPos _
> Lib "user32" (lpPoint As POINTAPI) As Long
>
> Sub SetTime()
> KillTime = Now + WaitTime / 1440
> Application.OnTime KillTime, "TestForShutDown"
> GetCursorPos CursPos
> End Sub
>
> Sub TestForShutDown()
> Dim CP As POINTAPI
> GetCursorPos CP
> If CursPos.X = CP.X And CursPos.Y = CP.Y Then
> With Application
> .CommandBars("AutoClose").Visible = True
> KillTime = Now + 10 / 1440
> .OnTime KillTime, "Kill"
> End With
> Else
> Call SetTime
> End If
> End Sub
>
> Sub ContinueWorking()
> With Application
> .CommandBars("AutoClose").Visible = False
> .OnTime KillTime, "Kill", Schedule:=False
> End With
> Call SetTime
> End Sub
>
> Sub Kill()
> With Application
> .CommandBars("AutoClose").Delete
> If Now < KillTime Then .OnTime KillTime, "Kill", Schedule:=False
> End With
> ThisWorkbook.Close True
> End Sub
>
> Sub Disable()
> With Application
> .CommandBars("AutoClose").Visible = False
> If Now < KillTime Then .OnTime KillTime, "Kill", Schedule:=False
> End With
> End Sub
>
> Sub MakeToolBar()
> Dim CB As CommandBar
> Dim Btn As CommandBarButton
> Dim i As Integer
> Dim arr As Variant, arr2 As Variant
>
> With Application
> .ScreenUpdating = False
> On Error Resume Next
> .CommandBars("AutoClose").Delete
> On Error GoTo 0
> Set CB = .CommandBars.Add("AutoClose", Temporary:=True)
> End With
> arr = Array("Continue Working", "Close Now", "Disable")
> arr2 = Array("ContinueWorking", "Kill", "Disable")
> For i = 0 To 2
> Set Btn = CB.Controls.Add
> With Btn
> .Caption = arr(i)
> .OnAction = arr2(i)
> .Style = msoButtonCaption
> .BeginGroup = (i > 0)
> End With
> Next
> Application.ScreenUpdating = True
> CB.Visible = False
> End Sub
>
> Best regards,
> Greg
>

**chris100** · 04-03-2006, 09:50 AM

Thanks Greg,

I'll try it when i get home from work and let you know.

Chris

Greg Wilson · 04-03-2006, 04:10 PM

Chris,

I confirmed that there's a problem the way I have it set up. I have created
separate TestTime and KillTime variables which appears to resolve the
problem. Use the appended code instead of what I gave you earlier. The
WaitTime variable is the wait time in minutes. I set it to a very short
period of 0.1. Normally, this would be in the order of, say, 20.

I checked it out on my lunch break so I was in a hurry. Hope I didn't miss
something again.

Regards,
Greg

'xxxxxxxx Paste to the ThisWorkbook module xxxxxxxx

Private Sub Workbook_Open()
Dim msg As String
msg = "This workbook will auto-close after " & WaitTime & _
" minutes of inactivity. "
MsgBox msg, vbInformation, "Auto-Close"
Call MakeToolBar
Call SetTime
End Sub

'xxxxxxxx Paste to a standard module xxxxxxxx

Option Explicit
Public Const WaitTime As Single = 0.1
Dim KillTime As Date
Dim TestTime As Date
Private Type POINTAPI
X As Long
Y As Long
End Type
Dim CursPos As POINTAPI
Private Declare Function GetCursorPos _
Lib "user32" (lpPoint As POINTAPI) As Long

Sub SetTime()
TestTime = Now + WaitTime / 1440
Application.OnTime TestTime, "TestForShutDown"
GetCursorPos CursPos
End Sub

Sub TestForShutDown()
Dim CP As POINTAPI
GetCursorPos CP
If CursPos.X = CP.X And CursPos.Y = CP.Y Then
With Application
.CommandBars("AutoClose").Visible = True
KillTime = Now + 0.1 / 1440
.OnTime KillTime, "Kill"
End With
Else
Call SetTime
End If
End Sub

Sub ContinueWorking()
With Application
..CommandBars("AutoClose").Visible = False
..OnTime KillTime, "Kill", Schedule:=False
End With
Call SetTime
End Sub

Sub Kill()
With Application
.CommandBars("AutoClose").Delete
If Now < KillTime Then .OnTime KillTime, "Kill", Schedule:=False
End With
ThisWorkbook.Close True
End Sub

Sub Disable()
With Application
.CommandBars("AutoClose").Visible = False
If Now < KillTime Then .OnTime KillTime, "Kill", Schedule:=False
If Now < TestTime Then .OnTime TestTime, "TestForShutDown",
Schedule:=False
End With
End Sub

Sub MakeToolBar()
Dim CB As CommandBar
Dim Btn As CommandBarButton
Dim i As Integer
Dim arr As Variant, arr2 As Variant

With Application
..ScreenUpdating = False
On Error Resume Next
..CommandBars("AutoClose").Delete
On Error GoTo 0
Set CB = .CommandBars.Add("AutoClose", Temporary:=True)
End With
arr = Array("Continue Working", "Close Now", "Disable")
arr2 = Array("ContinueWorking", "Kill", "Disable")
For i = 0 To 2
Set Btn = CB.Controls.Add
With Btn
..Caption = arr(i)
..OnAction = arr2(i)
..Style = msoButtonCaption
..BeginGroup = (i > 0)
End With
Next
Application.ScreenUpdating = True
CB.Visible = False
End Sub

"chris100" wrote:

>
> Thanks Greg,
>
> I'll try it when i get home from work and let you know.
>
> Chris
>
>
> --
> chris100
> ------------------------------------------------------------------------
> chris100's Profile: http://www.excelforum.com/member.php...o&userid=25166
> View this thread: http://www.excelforum.com/showthread...hreadid=361302
>
>

Greg Wilson · 04-04-2006, 12:10 AM

I still got the occasional error so I revamped it a bit. I also IMO improved
the toolbar by forcing it to appear at the top-left corner area of the screen
and don't allow resize. This has been a work in progress and hopefully this
is the final version. Hav'nt found any problem with the revamp.

When in actual use you would change the WaitTime variable to something like
10 (minutes) instead of 0.1. It may be proven advisable to also use the
Workbook_SheetChange event to fire the SetTime macro.

Ignore all previous versions and go with this:

'xxxxx Paste to ThisWorkbook module xxxxx
Private Sub Workbook_Open()
Dim msg As String
msg = "This workbook will auto-close after " & WaitTime & _
" minutes of inactivity. "
MsgBox msg, vbInformation, "Auto-Close"
Call MakeToolBar
Call SetTime
End Sub

'xxxxx Paste to a standard module xxxxx
Option Explicit
Public Const WaitTime As Single = 0.1
Dim KillTime As Date
Dim TestTime As Date
Dim KillWithBtn As Boolean
Private Type POINTAPI
X As Long
Y As Long
End Type
Dim CursPos As POINTAPI
Private Declare Function GetCursorPos _
Lib "user32" (lpPoint As POINTAPI) As Long

Sub SetTime()
TestTime = Now + WaitTime / 1440
Application.OnTime TestTime, "TestForShutDown"
GetCursorPos CursPos
End Sub

Sub TestForShutDown()
Dim CP As POINTAPI
GetCursorPos CP
If CursPos.X = CP.X And CursPos.Y = CP.Y Then
With Application
.CommandBars("AutoClose").Visible = True
KillTime = Now + 0.1 / 1440
.OnTime KillTime, "Kill"
End With
Else
Call SetTime
End If
End Sub

Sub ContinueWorking()
With Application
.CommandBars("AutoClose").Visible = False
.OnTime KillTime, "Kill", Schedule:=False
End With
Call SetTime
End Sub

Sub Kill()
With Application
If Not .CommandBars.ActionControl Is Nothing Then
.OnTime KillTime, "Kill", Schedule:=False
End If
.CommandBars("AutoClose").Delete
End With
ThisWorkbook.Close True
End Sub
Sub Disable()
With Application
.CommandBars("AutoClose").Visible = False
If Now < KillTime Then .OnTime KillTime, "Kill", Schedule:=False
If Now < TestTime Then .OnTime TestTime, "TestForShutDown",
Schedule:=False
End With
End Sub

Sub MakeToolBar()
Dim CB As CommandBar
Dim Btn As CommandBarButton
Dim i As Integer
Dim arr As Variant, arr2 As Variant

With Application
.ScreenUpdating = False
On Error Resume Next
.CommandBars("AutoClose").Delete
On Error GoTo 0
Set CB = .CommandBars.Add("AutoClose", Temporary:=True)
End With
CB.Protection = msoBarNoResize
CB.Top = 200
CB.Left = 200
arr = Array("Continue Working", "Close Now", "Disable")
arr2 = Array("ContinueWorking", "Kill", "Disable")
For i = 0 To 2
Set Btn = CB.Controls.Add
With Btn
.Caption = arr(i)
.OnAction = arr2(i)
.Style = msoButtonCaption
.BeginGroup = (i > 0)
End With
Next
Application.ScreenUpdating = True
CB.Visible = False
End Sub

Regards,
Greg