Hi all,

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

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

Thanks in advance,

Chri

--
chris10
-----------------------------------------------------------------------
chris100's Profile: http://www.excelforum.com/member.php...fo&userid=2516
View this thread: http://www.excelforum.com/showthread.php?threadid=36130

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

Thanks Greg,

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

thanks again for your $0.02. Helped a lot.

chri

--
chris10
-----------------------------------------------------------------------
chris100's Profile: http://www.excelforum.com/member.php...fo&userid=2516
View this thread: http://www.excelforum.com/showthread.php?threadid=36130

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....


--
chris100
------------------------------------------------------------------------
chris100's Profile: http://www.excelforum.com/member.php...o&userid=25166
View this thread: http://www.excelforum.com/showthread...hreadid=361302

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

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

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

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

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

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