VBA Application.OnTime issues

[taigovinda]

I have a shared file on a LAN. I borrowed some code online to kick out idle users (who presumably forgot to get out of the file). I tweaked it a bit so that it puts them to read-only instead of kicking them out altogether (not sure if it exhibited the undesirable behavior I'm about to describe, before I tweaked it).

Upon opening the workbook, I want the code to wait five minutes and if the user hasn't done anything (selection change, select different sheet) in the workbook then they will be switched to read-only in that workbook. Every time they do something, I want the five minutes to start over again. And of course if they close the workbook, I want the timer to be canceled.

It seems like the 'start over again' and/or 'cancel' bit isn't always working. I'm not sure if it works sometimes or never. If I go into the file, make my changes and close it (save or not)... then if I don't exit my Excel session, the timer will keep going and it will re-open the book to tell me it's switching to read-only.

What did I do wrong? What do I change to ensure the timer is getting reset when they do something and stopped when they close the book?

Thanks!!
Tai

In ThisWorkBook module:

Option Explicit


Private Sub Workbook_Open()
Dim myDate As Date
    
'start a clock... after x minutes of inactivity, shut it without saving so others can get in
'http://excelribbon.tips.net/T008192_Forcing_a_Workbook_to_Close_after_Inactivity.html
   Call StopTimer
   Call SetTimer
   
End Sub


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



Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
  ByVal Target As Excel.Range)
    Call StopTimer
    Call SetTimer


End Sub


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Call StopTimer
    Call SetTimer
End Sub

In a different module:

Option Explicit


Dim DownTime As Variant, strWkbk As String


Sub SetTimer()
    strWkbk = ThisWorkbook.FullName
    DownTime = Now + TimeValue("00:05:00")
    Application.OnTime EarliestTime:=DownTime, _
      Procedure:="ShutDown", Schedule:=True
      
End Sub


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


Sub ShutDown()
    'Application.DisplayAlerts = False
    If ThisWorkbook.ReadOnly Or IsFileOpen(strWkbk) = False Then 'don't need to kick you out if you're read-only, or if this is running when the file's not open
        StopTimer
        SetTimer
        Exit Sub
    End If
    'kick you out if you're not read-only
    With ThisWorkbook
'        .Saved = True
'        .Close False 'we won't close it, we'll just flip them to read-only
        Application.DisplayAlerts = False
        .ChangeFileAccess Mode:=xlReadOnly
        Application.DisplayAlerts = True
        MsgBox "You were dilly-dallying in the file.  Now you've been switched to read-only.", vbInformation, "You're Read-Only Now!"
    End With
End Sub

 

[JoeMo]

Just to clarify, the procedures you list as being in a "Different Module" must be in a standard module, not in sheet code or Thisworkbook. Is that the case?

Can you post the UDF IsFileOpen so we can see what are the argument(s) for it? This could be your problem if that UDF wants just the file name like "MyFile.xlsm" and you are actually giving it the full path to that file like "C:\Users\User\MyFile.xlsm". Also, you may not need or want to precede each Call SetTimer with Call StopTimer. The latter may only be needed in the Workbook_BeforeClose procedure.

 

[taigovinda]

Hi Joe, thanks for the quick response.
The "different module" is indeed a standard module.
Here's the UDF, I had accidentally omitted it (it's in the same "different" standard module as the rest of what I put in my first post).

Function IsFileOpen(strFullPathFileName As String) As Boolean
'//see http://www.xcelfiles.com/IsFileOpen.html for a different version that checks if *anyone* has a file open...


Dim wkBk As Workbook


On Error Resume Next
Set wkBk = Workbooks(Right(strFullPathFileName, Len(strFullPathFileName) - InStrRev(strFullPathFileName, "\")))
If Not wkBk Is Nothing Then GoTo FileIsOpen


'added to prevent failure if unsaved book is open
Set wkBk = Workbooks(strFullPathFileName)
On Error GoTo 0


If Not wkBk Is Nothing Then GoTo FileIsOpen
Exit Function
FileIsOpen:
    '// Someone has it open!
    IsFileOpen = True
End Function

Let me know if you see something else I'm missing; I don't know why I would need or not need StopTimer other than Workbook_BeforeClose (since I don't really understand application.ontime well), but I'll definitely try taking it away from everywhere else.

Thanks!
Tai

 

[JoeMo]

That UDF looks ok as it actually uses only the file name part of the FullName. Looking at your code some more I think, for me, it might be easier to write something from scratch that serves your purpose rather than try to repair what you have. It's bedtime for me, but if you haven't had a solution from someone else, I'll try to do that tomorrow.

 

[JoeMo]

Decided to just modify the code you posted. See if this works for you.

In a standard module:

Option Explicit


Dim DownTime As Variant, strWkbk As String


Sub SetTimer()
    strWkbk = ThisWorkbook.FullName
    If ThisWorkbook.ReadOnly Then
        DownTime = Now
    Else
        DownTime = Now + TimeValue("00:05:00")
    End If
    Application.OnTime EarliestTime:=DownTime, _
      Procedure:="ShutDown", Schedule:=True
      
End Sub


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


Sub ShutDown()
Dim msg As String
If Not IsFileOpen(strWkbk) Then Exit Sub
    If ThisWorkbook.ReadOnly Then 'don't need to kick you out if you're read-only, or if this is running when the file's not open
        Application.DisplayAlerts = False
        ThisWorkbook.ChangeFileAccess Mode:=xlReadWrite
        Application.DisplayAlerts = True
        SetTimer
        Exit Sub
    Else
    
    'kick you out if you're not read-only
        With ThisWorkbook
    '        .Saved = True
    '        .Close False 'we won't close it, we'll just flip them to read-only
'            StopTimer
            Application.DisplayAlerts = False
            .ChangeFileAccess Mode:=xlReadOnly
            Application.DisplayAlerts = True
            msg = "You were dilly-dallying in the file.  Now you've been switched to read-only."
            msg = msg & vbCrLf & vbCrLf & "FULL READ/WRITE ACCESS WILL BE RESTORED WHEN YOU COMMENCE ACTIVITY"
            MsgBox msg, vbInformation, "You're Read-Only Now!"
            StopTimer
        End With
    End If
End Sub
Function IsFileOpen(strFullPathFileName As String) As Boolean
'//see http://www.xcelfiles.com/IsFileOpen.html for a different version that checks if *anyone* has a file open...
Dim wkBk As Workbook
On Error Resume Next
Set wkBk = Workbooks(Right(strFullPathFileName, Len(strFullPathFileName) - InStrRev(strFullPathFileName, "\")))
If Not wkBk Is Nothing Then GoTo FileIsOpen
'added to prevent failure if unsaved book is open
Set wkBk = Workbooks(strFullPathFileName)
On Error GoTo 0
If Not wkBk Is Nothing Then GoTo FileIsOpen
Exit Function
FileIsOpen:
    '// Someone has it open!
    IsFileOpen = True
End Function

In a Thisworkbook module:

Option Explicit
Private Sub Workbook_Open()
'start a clock... after x minutes of inactivity, shut it without saving so others can get in
'http://excelribbon.tips.net/T008192_Forcing_a_Workbook_to_Close_after_Inactivity.html
   Call SetTimer
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call StopTimer
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Call StopTimer
Call SetTimer
End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Call StopTimer
Call SetTimer
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
  ByVal Target As Excel.Range)
    Call StopTimer
    Call SetTimer
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Call StopTimer
    Call SetTimer
End Sub