Timed InputBox or message box

[Tom Huntford]

I have searched and searched, but not found an answer to this:

I have a workbook that is shared by users, and needs to be auto-closed after 10 minutes of inactivity. The VBA code to close the workbook if no changes have been made in 10 min works OK. However, I want to give a user who has been using the workbook for 10 minutes, is actually there, an opportunity to keep the file open. So I need to have an input box or message box appear for a certain length of time, say, 10 seconds. "This workbook is about to be closed due to inactivity. Click "Yes" if you want to keep this workbook open." If no one responds to the prompt, the box is closed and the auto-close routine performs. If "Yes" is entered, the workbook is kept open.

This is what I have, but I don't like the way it works, its fluky.

Public Const ShowDurationSecs As Integer = 1.75
Public Const NUM_MINUTES = 10

Dim Rslt As Integer
Rslt = CreateObject("WScript.Shell").Popup( _
"This workbook has been inactive for more than " & NUM_MINUTES & " minutes." & vbNewLine & vbNewLine & "Keep this workbook open?", ShowDurationSecs, _
"Shared Workbook has been inactive...", 4 + 32)
If Rslt = 6 Then
End
Else: End If

Suggestions gratefully accepted.

 

[Tom Huntford]

Couple of corrections--
1. Needed an if-then for consistent handling of the workbook being opened in Read Only mode by a user.
2. Took out some code that doesn't directly apply to this thread.

OK, I have a solution. Maybe someone will find this useful. I know it is not elegant, there are a couple of work-around's. If someone has a better idea, I'd love to use it.

PROBLEM:

1. The Workbook_Open sub only is good for one instance of the inactivity timer.
2. The SheetSelectionChange sub only re-starts the timer when there is a change, so if the user clicked "Yes" the question "Keep the File Open?", there is no change to the sheet, so the timer is not re-set, and the SheetSelectionChange timer ends up being good for only one time.
3. Therefore, once there is a change, and a subsequent period of inactivity, the codes I found did not produce a consistent timer that monitored inactivity regardless of how much activity had been done.

SOLUTION:

1. Upon opening the workbook, select the cell to the right of the active cell, then go back to the active cell. This forces an immediate SheetSelectionChange event.
2. Take all timer code out of the Workbook_Open and leave it only in the SheetSelectionChange.
3. Use a timed popup to flash a message to the user. I found the only time parameter that worked consistently for the popup was 1, which produces a short duration, so I looped the flash. In my case, the user gets 10 popup flashes, then the workbook automatically saves changes and closes.
4. If the user chooses "Yes" to the question, "Keep the file open?", move one cell to the right then back again, thus forcing another SheetSelectionChange event, and thus re-starting the timer.

CODE:

a. Workbook code

Private Sub Workbook_Open()'TEST IF FILE IS OPENED READ-ONLY
If ActiveWorkbook.ReadOnly = True Then
    End
Else: End If
'FORCE SHEETSELECTIONCHANGE MACRO FOR TIMER INITIALIZATION
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(0, -1).Select
End Sub


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
'TEST IF FILE IS OPENED READ-ONLY
If ActiveWorkbook.ReadOnly = True Then
    End
Else: End If
'TIMER FOR ADDING ANOTHER 10 MIN AFTER EACH ACTIVITY
On Error Resume Next
Application.OnTime CloseTime, "CloseIfInactive", , False
currtime = Now
AddInterval = TimeValue("00:10:00")
CloseTime = currtime + AddInterval
On Error Resume Next
Application.OnTime CloseTime, "CloseIfInactive", , True
On Error GoTo 0
End Sub

b. Module Code

'PUT THIS AT THE TOP OF THE MODULE
Public CloseTime As Date


'FLASH MESSAGE TO USER, IF NO RESPONSE, AUTO CLOSE
Sub CloseIfInactive()
If ActiveWorkbook.ReadOnly = True Then
End
Else: End If
COUNTER = 1
N1:
 Dim RESULT As Integer
 RESULT = CreateObject("WScript.Shell").popup("Keep Tracker open?", 1, "Inactive for 12 sec...", 4 + 48 + 4096)
'POPUP SYNTAX:  POPUP("MESSAGE",TIME TO DISPLAY [note: only value I found to work is 1],"TITLE", BUTTON TYPES + ICON TYPES + OTHER TYPES)
'RESULTS:  NO INPUT = -1   OK = 1   CANCEL = 2   ABORT = 3   RETRY = 4   IGNORE = 5   YES = 6   NO = 7   TRY AGAIN = 10   CONTINUE = 11
'FOR LIST OF PARAMETER VALUES SEE https://msdn.microsoft.com/en-us/library/x83z1d9f(v=VS.85).aspx
'IF NO RESPONSE
If RESULT = -1 Then
COUNTER = COUNTER + 1
    'FLASH MESSAGE 10 TIMES, BECAUSE THE ONLY PARAMETER FOR POPUP DISPLAY TIME THAT WORKS IS 1
    If COUNTER > 10 Then
            GoTo CLOSE_PROMPT
    Else
            GoTo N1
    End If
Else: End If
'IF RESPONSE IS "NO"
If RESULT = 7 Then
CLOSE_PROMPT:
     Call BackupSaveAndClose
Else: End If
'IF RESPONSE IS "YES"
If RESULT = 6 Then
        'MOVE TO THE NEXT CELL AND BACK TO RE-START THE TIMER
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Offset(0, -1).Select
Else: End If
End Sub