Timer to close workbook when no activity detected

[swedbera]

Regarding the inactivity timer that Greg Wilson was helping another user
with....

I am unable to get this code to work. Does it need a reference or is there
something missing here?

Please help.

Arlene

[Bob Phillips]

Uh ... show the code?

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"swedbera" <[email protected]> wrote in message
news:[email protected]...
> Regarding the inactivity timer that Greg Wilson was helping another user
> with....
>
> I am unable to get this code to work. Does it need a reference or is
there
> something missing here?
>
> Please help.
>
> Arlene

[swedbera]

I apologize,

I thought that my message was being posted along with the original message
from this other person. Here is the code.


Arlene

'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


"Bob Phillips" wrote:

> Uh ... show the code?
>
> --
> HTH
>
> Bob Phillips
>
> (replace somewhere in email address with gmail if mailing direct)
>
> "swedbera" <[email protected]> wrote in message
> news:[email protected]...
> > Regarding the inactivity timer that Greg Wilson was helping another user
> > with....
> >
> > I am unable to get this code to work. Does it need a reference or is
> there
> > something missing here?
> >
> > Please help.
> >
> > Arlene
>
>
>

[Bob Phillips]

I haven't tested it, but it seems about right. Did you store the code in the
correct modules as suggested? If so, what happens when you run?

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"swedbera" <[email protected]> wrote in message
news:[email protected]...
> I apologize,
>
> I thought that my message was being posted along with the original message
> from this other person. Here is the code.
>
>
> Arlene
>
> '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
>
>
> "Bob Phillips" wrote:
>
> > Uh ... show the code?
> >
> > --
> > HTH
> >
> > Bob Phillips
> >
> > (replace somewhere in email address with gmail if mailing direct)
> >
> > "swedbera" <[email protected]> wrote in message
> > news:[email protected]...
> > > Regarding the inactivity timer that Greg Wilson was helping another
user
> > > with....
> > >
> > > I am unable to get this code to work. Does it need a reference or is
> > there
> > > something missing here?
> > >
> > > Please help.
> > >
> > > Arlene
> >
> >
> >

[swedbera]

I had them in the wrong modules. Also, the person who submitted the code did
so a few times after changing a couple of the variables and had overlooked
changing them in every occurance. I finally got it working.

Thank you

Arlene

"Bob Phillips" wrote:

> I haven't tested it, but it seems about right. Did you store the code in the
> correct modules as suggested? If so, what happens when you run?
>
> --
> HTH
>
> Bob Phillips
>
> (replace somewhere in email address with gmail if mailing direct)
>
> "swedbera" <[email protected]> wrote in message
> news:[email protected]...
> > I apologize,
> >
> > I thought that my message was being posted along with the original message
> > from this other person. Here is the code.
> >
> >
> > Arlene
> >
> > '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
> >
> >
> > "Bob Phillips" wrote:
> >
> > > Uh ... show the code?
> > >
> > > --
> > > HTH
> > >
> > > Bob Phillips
> > >
> > > (replace somewhere in email address with gmail if mailing direct)
> > >
> > > "swedbera" <[email protected]> wrote in message
> > > news:[email protected]...
> > > > Regarding the inactivity timer that Greg Wilson was helping another
> user
> > > > with....
> > > >
> > > > I am unable to get this code to work. Does it need a reference or is
> > > there
> > > > something missing here?
> > > >
> > > > Please help.
> > > >
> > > > Arlene
> > >
> > >
> > >
>
>
>

[Greg Wilson]

I have an updated version if you are interested. Change the DefaultWaitTime
constant to something appropriate (minutes). It is currently set very short
for testing purposes. It typically runs longer than the set time because when
you click the button to continue working it instantly records the mouse
pointer position and you usually move it a bit while clicking so this
registers as movement.

'xxxxx Paste to ThisWorkbook module xxxxx
Private Sub Workbook_Open()
Call MakeToolBar
Call SetTime
End Sub

'xxxxx Paste to a standard module xxxxx
Option Explicit
Public Const DefaultWaitTime As Single = 0.1
Const DefaultShowTBTime As Single = 0.2
Dim WaitTime As Single
Dim ShowTBTime As Single
Dim KillTime As Date
Dim TestTime As Date
Dim DisableAutoClose 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 'minutes per day
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
Beep
KillTime = Now + ShowTBTime / 1440 'minutes per day
With Application
With .CommandBars("AutoClose")
.Controls(1).Caption = _
"Warning: This workbook will auto-close at " & Format(KillTime,
"hh:mm:ss AM/PM")
.Visible = True
End With
.OnTime KillTime, "Kill"
End With
Else
Call SetTime
End If
End Sub

Sub ContinueWorking()
With Application
.CommandBars("AutoClose").Visible = False
'Suppress error in case Kill cancelled by ShowOptions
On Error Resume Next
.OnTime KillTime, "Kill", Schedule:=False
On Error GoTo 0
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 < TestTime Then .OnTime TestTime, "TestForShutDown",
Schedule:=False
DisableAutoClose = True
End With
End Sub
Sub ShowOptions()
With Application
.OnTime KillTime, "Kill", Schedule:=False
.CommandBars("AutoCloseOptions").ShowPopup
End With
If Not DisableAutoClose Then Call ContinueWorking
End Sub
Sub ChangeWaitTime()
WaitTime = Application.CommandBars.ActionControl.Text
End Sub
Sub ChangeShowTBTime()
Dim capt As String
With Application
ShowTBTime = .CommandBars.ActionControl.Text
.CommandBars("AutoClose").Controls(1).Caption = capt
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

WaitTime = DefaultWaitTime
ShowTBTime = DefaultShowTBTime
With Application
.ScreenUpdating = False
On Error Resume Next
.CommandBars("AutoClose").Delete
On Error GoTo 0
Set CB = .CommandBars.Add("AutoClose", Temporary:=True)
End With
With CB
.Top = 200
.Left = 200
.Protection = msoBarNoResize
.Visible = False
End With
arr = Array("", "Continue Working", "Close Now", "Options")
arr2 = Array("", "ContinueWorking", "Kill", "ShowOptions")
For i = 0 To 3
Set btn = CB.Controls.Add
With btn
.Width = IIf(i = 0, 312, 100)
.Caption = arr(i)
.OnAction = arr2(i)
.Style = msoButtonCaption
.BeginGroup = (i > 0)
End With
Next
CB.Width = 345
Call MakeAutoCloseOptionsTB
Application.ScreenUpdating = True

End Sub

Sub MakeAutoCloseOptionsTB()
Dim Popup As CommandBar
Dim ctrl As CommandBarControl, ctrl2 As CommandBarControl
Dim i As Integer
Dim capt1 As String, capt2 As String

capt1 = "No activity limit"
capt2 = "Toolbar display time"
Set Popup = Application.CommandBars.Add("AutoCloseOptions", msoBarPopup, _
Temporary:=True)
With Popup
Set ctrl = .Controls.Add
ctrl.Caption = "Disable AutoClose"
ctrl.OnAction = "Disable"
For i = 0 To 1
Set ctrl = Popup.Controls.Add(msoControlPopup)
ctrl.Caption = IIf(i = 0, capt1, capt2)
Set ctrl2 = ctrl.Controls.Add(msoControlEdit)
ctrl2.Caption = "Minutes:"
ctrl2.OnAction = IIf(i = 0, "ChangeWaitTime", "ChangeShowTBTime")
ctrl2.Text = IIf(i = 0, DefaultWaitTime, DefaultShowTBTime)
Next
End With
End Sub

[swedbera]

Hi Greg,

Thanks so much! I still couldn't get it to work, so I'll try your updated
version. There is one thing that I would like to change and that is to
eliminate the ability for the user to disable the timer. How would I change
it to make that work?

Arlene

"Greg Wilson" wrote:

> I have an updated version if you are interested. Change the DefaultWaitTime
> constant to something appropriate (minutes). It is currently set very short
> for testing purposes. It typically runs longer than the set time because when
> you click the button to continue working it instantly records the mouse
> pointer position and you usually move it a bit while clicking so this
> registers as movement.
>
> 'xxxxx Paste to ThisWorkbook module xxxxx
> Private Sub Workbook_Open()
> Call MakeToolBar
> Call SetTime
> End Sub
>
> 'xxxxx Paste to a standard module xxxxx
> Option Explicit
> Public Const DefaultWaitTime As Single = 0.1
> Const DefaultShowTBTime As Single = 0.2
> Dim WaitTime As Single
> Dim ShowTBTime As Single
> Dim KillTime As Date
> Dim TestTime As Date
> Dim DisableAutoClose 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 'minutes per day
> 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
> Beep
> KillTime = Now + ShowTBTime / 1440 'minutes per day
> With Application
> With .CommandBars("AutoClose")
> .Controls(1).Caption = _
> "Warning: This workbook will auto-close at " & Format(KillTime,
> "hh:mm:ss AM/PM")
> .Visible = True
> End With
> .OnTime KillTime, "Kill"
> End With
> Else
> Call SetTime
> End If
> End Sub
>
> Sub ContinueWorking()
> With Application
> .CommandBars("AutoClose").Visible = False
> 'Suppress error in case Kill cancelled by ShowOptions
> On Error Resume Next
> .OnTime KillTime, "Kill", Schedule:=False
> On Error GoTo 0
> 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 < TestTime Then .OnTime TestTime, "TestForShutDown",
> Schedule:=False
> DisableAutoClose = True
> End With
> End Sub
> Sub ShowOptions()
> With Application
> .OnTime KillTime, "Kill", Schedule:=False
> .CommandBars("AutoCloseOptions").ShowPopup
> End With
> If Not DisableAutoClose Then Call ContinueWorking
> End Sub
> Sub ChangeWaitTime()
> WaitTime = Application.CommandBars.ActionControl.Text
> End Sub
> Sub ChangeShowTBTime()
> Dim capt As String
> With Application
> ShowTBTime = .CommandBars.ActionControl.Text
> .CommandBars("AutoClose").Controls(1).Caption = capt
> 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
>
> WaitTime = DefaultWaitTime
> ShowTBTime = DefaultShowTBTime
> With Application
> .ScreenUpdating = False
> On Error Resume Next
> .CommandBars("AutoClose").Delete
> On Error GoTo 0
> Set CB = .CommandBars.Add("AutoClose", Temporary:=True)
> End With
> With CB
> .Top = 200
> .Left = 200
> .Protection = msoBarNoResize
> .Visible = False
> End With
> arr = Array("", "Continue Working", "Close Now", "Options")
> arr2 = Array("", "ContinueWorking", "Kill", "ShowOptions")
> For i = 0 To 3
> Set btn = CB.Controls.Add
> With btn
> .Width = IIf(i = 0, 312, 100)
> .Caption = arr(i)
> .OnAction = arr2(i)
> .Style = msoButtonCaption
> .BeginGroup = (i > 0)
> End With
> Next
> CB.Width = 345
> Call MakeAutoCloseOptionsTB
> Application.ScreenUpdating = True
>
> End Sub
>
> Sub MakeAutoCloseOptionsTB()
> Dim Popup As CommandBar
> Dim ctrl As CommandBarControl, ctrl2 As CommandBarControl
> Dim i As Integer
> Dim capt1 As String, capt2 As String
>
> capt1 = "No activity limit"
> capt2 = "Toolbar display time"
> Set Popup = Application.CommandBars.Add("AutoCloseOptions", msoBarPopup, _
> Temporary:=True)
> With Popup
> Set ctrl = .Controls.Add
> ctrl.Caption = "Disable AutoClose"
> ctrl.OnAction = "Disable"
> For i = 0 To 1
> Set ctrl = Popup.Controls.Add(msoControlPopup)
> ctrl.Caption = IIf(i = 0, capt1, capt2)
> Set ctrl2 = ctrl.Controls.Add(msoControlEdit)
> ctrl2.Caption = "Minutes:"
> ctrl2.OnAction = IIf(i = 0, "ChangeWaitTime", "ChangeShowTBTime")
> ctrl2.Text = IIf(i = 0, DefaultWaitTime, DefaultShowTBTime)
> Next
> End With
> End Sub

[Greg Wilson]

To remove the option to disable the AutoClose, simply put a apostrophe in
front of the following lines contained in the last macro
MakeAutoCloseOptionsTB. This will convert them to comment text (should turn
green) and the compiler will ignore them. Alternatively delete them.

'Set ctrl = .Controls.Add
'ctrl.Caption = "Disable AutoClose"
'ctrl.OnAction = "Disable"

I copied my code from my post and pasted it respectively to the ThisWorkbook
module (Private Sub Workbook_Open) and to a standard module (all other
macros).
Except for correcting forced wordwrap caused by posting there were no
problems. (Where wordwrap causes a syntax error the lines will turn red).

There may be an issue with closing the wb without cancelling the next
scheduled appearance of the tool bar. If problems are encountered this can be
fixed. I wrote this to help someone and never use it myself so it has never
been rigorously tested.

Greg

"swedbera" wrote:

> Hi Greg,
>
> Thanks so much! I still couldn't get it to work, so I'll try your updated
> version. There is one thing that I would like to change and that is to
> eliminate the ability for the user to disable the timer. How would I change
> it to make that work?
>
> Arlene
>
> "Greg Wilson" wrote:
>
> > I have an updated version if you are interested. Change the DefaultWaitTime
> > constant to something appropriate (minutes). It is currently set very short
> > for testing purposes. It typically runs longer than the set time because when
> > you click the button to continue working it instantly records the mouse
> > pointer position and you usually move it a bit while clicking so this
> > registers as movement.
> >
> > 'xxxxx Paste to ThisWorkbook module xxxxx
> > Private Sub Workbook_Open()
> > Call MakeToolBar
> > Call SetTime
> > End Sub
> >
> > 'xxxxx Paste to a standard module xxxxx
> > Option Explicit
> > Public Const DefaultWaitTime As Single = 0.1
> > Const DefaultShowTBTime As Single = 0.2
> > Dim WaitTime As Single
> > Dim ShowTBTime As Single
> > Dim KillTime As Date
> > Dim TestTime As Date
> > Dim DisableAutoClose 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 'minutes per day
> > 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
> > Beep
> > KillTime = Now + ShowTBTime / 1440 'minutes per day
> > With Application
> > With .CommandBars("AutoClose")
> > .Controls(1).Caption = _
> > "Warning: This workbook will auto-close at " & Format(KillTime,
> > "hh:mm:ss AM/PM")
> > .Visible = True
> > End With
> > .OnTime KillTime, "Kill"
> > End With
> > Else
> > Call SetTime
> > End If
> > End Sub
> >
> > Sub ContinueWorking()
> > With Application
> > .CommandBars("AutoClose").Visible = False
> > 'Suppress error in case Kill cancelled by ShowOptions
> > On Error Resume Next
> > .OnTime KillTime, "Kill", Schedule:=False
> > On Error GoTo 0
> > 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 < TestTime Then .OnTime TestTime, "TestForShutDown",
> > Schedule:=False
> > DisableAutoClose = True
> > End With
> > End Sub
> > Sub ShowOptions()
> > With Application
> > .OnTime KillTime, "Kill", Schedule:=False
> > .CommandBars("AutoCloseOptions").ShowPopup
> > End With
> > If Not DisableAutoClose Then Call ContinueWorking
> > End Sub
> > Sub ChangeWaitTime()
> > WaitTime = Application.CommandBars.ActionControl.Text
> > End Sub
> > Sub ChangeShowTBTime()
> > Dim capt As String
> > With Application
> > ShowTBTime = .CommandBars.ActionControl.Text
> > .CommandBars("AutoClose").Controls(1).Caption = capt
> > 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
> >
> > WaitTime = DefaultWaitTime
> > ShowTBTime = DefaultShowTBTime
> > With Application
> > .ScreenUpdating = False
> > On Error Resume Next
> > .CommandBars("AutoClose").Delete
> > On Error GoTo 0
> > Set CB = .CommandBars.Add("AutoClose", Temporary:=True)
> > End With
> > With CB
> > .Top = 200
> > .Left = 200
> > .Protection = msoBarNoResize
> > .Visible = False
> > End With
> > arr = Array("", "Continue Working", "Close Now", "Options")
> > arr2 = Array("", "ContinueWorking", "Kill", "ShowOptions")
> > For i = 0 To 3
> > Set btn = CB.Controls.Add
> > With btn
> > .Width = IIf(i = 0, 312, 100)
> > .Caption = arr(i)
> > .OnAction = arr2(i)
> > .Style = msoButtonCaption
> > .BeginGroup = (i > 0)
> > End With
> > Next
> > CB.Width = 345
> > Call MakeAutoCloseOptionsTB
> > Application.ScreenUpdating = True
> >
> > End Sub
> >
> > Sub MakeAutoCloseOptionsTB()
> > Dim Popup As CommandBar
> > Dim ctrl As CommandBarControl, ctrl2 As CommandBarControl
> > Dim i As Integer
> > Dim capt1 As String, capt2 As String
> >
> > capt1 = "No activity limit"
> > capt2 = "Toolbar display time"
> > Set Popup = Application.CommandBars.Add("AutoCloseOptions", msoBarPopup, _
> > Temporary:=True)
> > With Popup
> > Set ctrl = .Controls.Add
> > ctrl.Caption = "Disable AutoClose"
> > ctrl.OnAction = "Disable"
> > For i = 0 To 1
> > Set ctrl = Popup.Controls.Add(msoControlPopup)
> > ctrl.Caption = IIf(i = 0, capt1, capt2)
> > Set ctrl2 = ctrl.Controls.Add(msoControlEdit)
> > ctrl2.Caption = "Minutes:"
> > ctrl2.OnAction = IIf(i = 0, "ChangeWaitTime", "ChangeShowTBTime")
> > ctrl2.Text = IIf(i = 0, DefaultWaitTime, DefaultShowTBTime)
> > Next
> > End With
> > End Sub