Option Explicit
Private Sub Workbook_Open()
Run "RemoveFromMenu"
With Application.CommandBars("Cell")
.Controls.Add(Type:=msoControlButton). _
Caption = "Lock Excel"
.Controls("Lock Excel"). _
OnAction = "LogOffPC"
End With
Run "StartTimer"
End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Run "DisableTimer"
Run "StartTimer"
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
Run "DisableTimer"
Run "StartTimer"
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Run "DisableTimer"
Run "StartTimer"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Run "DisableTimer"
Run "RemoveFromMenu"
End Sub
Option Explicit
Option Compare Text
Declare Function ExitWindowsEx& Lib "user32" _
(ByVal uFlags&, ByVal wReserved&)
Global Const EWX_LOGOFF = 0
Public IdleTime As Date
Sub StartTimer()
IdleTime = Now + TimeValue("00:02:00")
Application.ontime IdleTime, "LogOffPC"
End Sub
Sub DisableTimer()
On Error Resume Next
Application.ontime EarliestTime:=IdleTime, _
Procedure:="LogOffPC", Schedule:=False
End Sub
Sub LogOffPC()
Dim MyPIN As String, Action&, N&, Win As Window
Dim Book As Workbook, ThisBook As Workbook
Const MyPassword As String = "1234"
Set ThisBook = ActiveWorkbook
For Each Win In Windows
Win.Visible = False
Next Win
N = 1
EnterPIN:
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
MyPIN = Application.InputBox("Please enter PIN " & _
"to continue", "Time Expired - " & "Attempt " & N, "****")
If MyPIN <> MyPassword Then
If N < 3 Then
N = N + 1
GoTo EnterPIN
Else
MsgBox "It appears you've no authority to" & vbLf & _
"use this workbook - Logging off", , "Log-off PC"
RemoveFromMenu
For Each Win In Windows
Win.Visible = True
If Win.Caption = "Personal.xls" Then Win.Close
Next Win
For Each Book In Workbooks
Book.Save
Next Book
Application.DisplayAlerts = False
Action = ExitWindowsEx(EWX_LOGOFF, 0&)
Application.Quit
End If
Else
For Each Win In Windows
Win.Visible = True
If Win.Caption = "Personal.xls" Then Win.Close
Next Win
ThisBook.Activate
StartTimer
End If
End Sub
Private Sub RemoveFromMenu()
On Error Resume Next
With Application.CommandBars("Cell")
.Controls("Lock Excel").Delete
End With
End Sub
|