1

How to keep several modeless VBA forms running simultaneously on Excel?

I have a modeless form which pops up using UserForm.Show(False) when a workbook has been inactive for too long. The form has a timeout counter and if it's not interrupted (user form unloaded) by user before the counter reaches zero, then the workbook is closed. In UserForm_Activate there is a Do While - Loop with DoEvents to show the remaining time in the form.

This works fine on a single open workbook. But if I make a copy of the xlsm file and open both of them, then after the specified idle time both workbooks have their timeout forms opened but only the last one's counter will run. The first form's counter will stop as soon as the second form is opened.

Any ways to keep both modeless forms running?

Sheet1

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    LastEdit = Int(Timer)
End Sub

ThisWorkbook

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=False
End Sub

Private Sub Workbook_Open()
    NextCheck = DateAdd("s", CheckInterval, Now)
    Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=True
    Debug.Print "NextCheck for " & ThisWorkbook.Name & " - " & NextCheck
    LastEdit = Int(Timer)
End Sub

UserForm1

Option Explicit

Private Start As Single
Private CountDownActive As Boolean

Private Sub cmdContinue_Click()
    On Error Resume Next
    Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=False
    LastEdit = Int(Timer)
    CountDownActive = False
    Unload Me
End Sub

Private Sub UserForm_Activate()
    Debug.Print ThisWorkbook.Name & " - CountDownActive: " & CountDownActive
    If Not CountDownActive Then StartCountDown
End Sub

Private Sub UserForm_Terminate()
    On Error Resume Next
    Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=False
    LastEdit = Int(Timer)
    NextCheck = DateAdd("s", CheckInterval, Now)
    Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=True
    Debug.Print "NextCheck for " & ThisWorkbook.Name & " - " & NextCheck
End Sub

Private Sub StartCountDown()
    CountDownActive = True
    Start = Timer
    Do While Timer - Start < CountDownTime And Timer - LastEdit > TotalIdleTime - CountDownTime
        Me.Caption = Format(TimeSerial(0, 0, CountDownTime - Timer + Start), "nn:ss") & " remaining until closing '" & ThisWorkbook.Name & "'..."
        DoEvents
    Loop
    If Timer - LastEdit > TotalIdleTime - CountDownTime Then
        Application.DisplayAlerts = False
        ThisWorkbook.Close False
        Application.DisplayAlerts = True
    End If
    CountDownActive = False
    Unload Me
End Sub

Module1

Option Explicit

Public LastEdit As Single
Public NextCheck As Date

Public Const CheckInterval = 60         ' "00:01:00"
Public Const TotalIdleTime = 180        ' "00:03:00"
Public Const CountDownTime = 120        ' "00:02:00"

Private Function TimeOut()
    On Error Resume Next
    Dim IdleTimerForm As Object
    Select Case Timer - LastEdit
        Case Is < TotalIdleTime - CountDownTime
            Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=False
            NextCheck = DateAdd("s", CheckInterval, Now)
            Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=True
            Debug.Print "NextCheck for " & ThisWorkbook.Name & " - " & NextCheck
        Case Else
            Application.OnTime EarliestTime:=NextCheck, Procedure:="TimeOut", Schedule:=False
            Call AppActivate(Application.Caption)
            ThisWorkbook.Activate
            Set IdleTimerForm = New UserForm1
            IdleTimerForm.Show vbModeless
    End Select
End Function

There's also problem that when one of the user form counters reaches zero and unloads the form, it will unload ALL instances of that user form, from every currently open workbook.

MrFreeze
  • 25
  • 6
  • 1
    I can't confirm my suspicion right now, but my guess is that using the global instance of the `UserForm` is creating the problem. Try instanciating a new userform with `Set someUFVar = New Userform` – Nacorid Nov 15 '19 at 13:46
  • This was actually my first guess too and I tried it, but it didn't help. Thanks anyway. – MrFreeze Nov 15 '19 at 13:56
  • Can you please [edit] your question to include a [mcve] of the countdown code? – Chronocidal Nov 15 '19 at 16:02
  • @Chronocidal code added – MrFreeze Nov 15 '19 at 16:32
  • More code added and I did reproduce it on an empty workbook. Still having two problems; 1) only the latest counter keeps running 2) closing the latest workbook unloads all user forms from all open workbooks. – MrFreeze Nov 20 '19 at 15:50

0 Answers0