'*********************************************
 '<< CODE FOR THISWORKBOOK MODULE >>
 
Option Explicit 
 
 
Private Sub Workbook_Open() 
     
     '//remove any previous right-click control
    Run "RemoveFromMenu" 
     
     '//now add new right-click control
    With Application.CommandBars("Cell") 
        .Controls.Add(Type:=msoControlButton). _ 
        Caption = "Lock Excel" 
         
         '//assign procedure to this control
        .Controls("Lock Excel"). _ 
        OnAction = "LogOffPC" 
         
    End With 
     
     '//start the timer
    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) 
     
     '//disable timer
    Run "DisableTimer" 
     
     '//remove the right-click control
    Run "RemoveFromMenu" 
     
End Sub 
 
 '*********************************************
 
 
 
 
 '*********************************************
 '<< CODE FOR MODULE1 >>
 
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() '< Self-explanatory
     
     '**********************************
     '<< set your own idle time below >>
    IdleTime = Now + TimeValue("00:02:00") 
     '**********************************
     
    Application.ontime IdleTime, "LogOffPC" 
     
End Sub 
 
 
 
Sub DisableTimer() '< Self-explanatory
    On Error Resume Next 
    Application.ontime EarliestTime:=IdleTime, _ 
    Procedure:="LogOffPC", Schedule:=False 
End Sub 
 
 
 
 '// This example requires the user to type in a PIN to
 '// continue after the expiry of the idle time. The user
 '// is allowed 3 attempts to enter the correct PIN and
 '// if they fail the 3 times they will be logged-off, thus
 '// forcing the use of both; any Windows Log-in
 '// password, and any password that may be required
 '// to open the file.
 
Sub LogOffPC() 
     
    Dim MyPIN As String, Action&, N&, Win As Window 
    Dim Book As Workbook, ThisBook As Workbook 
     
     '*******************************************
     'Set your own password below
    Const MyPassword As String = "1234" 
     '*******************************************
     
    Set ThisBook = ActiveWorkbook 
     'hide any open books
    For Each Win In Windows 
        Win.Visible = False 
    Next Win 
    N = 1 
EnterPIN: 
    Application.EnableCancelKey = xlDisabled 
    Application.DisplayAlerts = False 
     'define the PIN as an input box entry
    MyPIN = Application.InputBox("Please enter PIN " & _ 
    "to continue", "Time Expired - " & "Attempt " & N, "****") 
     '---------------------------------------------------------------
     'if PIN is incorrect
    If MyPIN <> MyPassword Then 
         'if less than 3 attempts have another go
        If N < 3 Then 
            N = N + 1 
            GoTo EnterPIN 
        Else 
             'otherwise - log-off
            MsgBox "It appears you've no authority to" & vbLf & _ 
            "use this workbook - Logging off", , "Log-off PC" 
             
             'remove right-click menu item
            RemoveFromMenu 
             
             'unhide open books
            For Each Win In Windows 
                Win.Visible = True 
                If Win.Caption = "Personal.xls" Then Win.Close 
            Next Win 
             
             'save any open books
            For Each Book In Workbooks 
                Book.Save 
            Next Book 
             
             '//log-off
            Application.DisplayAlerts = False 
            Action = ExitWindowsEx(EWX_LOGOFF, 0&) 
            Application.Quit 
        End If 
         '---------------------------------------------------------------
    Else 
         'if PIN is correct, unhide open books
        For Each Win In Windows 
            Win.Visible = True 
            If Win.Caption = "Personal.xls" Then Win.Close 
        Next Win 
         'activate the book
        ThisBook.Activate 
         'restart the timer
        StartTimer 
    End If 
End Sub 
 
 
 
Private Sub RemoveFromMenu() 
     
    On Error Resume Next '< error = no control
     '//remove right-click control
    With Application.CommandBars("Cell") 
        .Controls("Lock Excel").Delete 
    End With 
     
End Sub 
 '*********************************************