VBA - Use Application.OnTime to mimic multitasking (redux) - WSH instead of Windows API

So something about the last post troubled me, I knew there was a better library out there for shelling and getting exit codes, running status etc. without resorting to the Windows API

The library I was missing was Windows Script Host Object Model (c:\Windows\SysWOW64\wshom.ocx) which beautifully gives a shelled process' running status, process id and also stdin, stdout, stderr pipes. It's quite curious as it is a Microsoft library but the description does not begin with Microsoft so not obvious whilst browsing Tools->References.

So we can write a cleaner version of the previous post thus ...

Option Explicit

Private moExec As IWshRuntimeLibrary.WshExec
Private mdicBackgroundTask As New Scripting.Dictionary



Sub LaunchNotePadAndDoBackgroundWork()
    
    Dim oShell As IWshRuntimeLibrary.WshShell
    Set oShell = New IWshRuntimeLibrary.WshShell
    
    Set moExec = oShell.Exec("notepad.exe")
    
    If moExec.ProcessID > 0 Then
        '* delete the dictionary resets the state
        Set mdicBackgroundTask = Nothing
        
        mdicBackgroundTask("MaxSeconds") = 5
        Application.OnTime Now(), "SomeTaskToGetOnWith"
        
        While Not mdicBackgroundTask("Cancel")
            '* yield control to OnTime scheduled procedures
            DoEvents
            
            '* check for cancel here for cases when background task stop scheduling it
            '* even if that means checking more than once
            CheckForCancel
        Wend
        Debug.Print "process terminated"
    End If
    
    DoEvents
End Sub

Sub CheckForCancel()
    '* seems that we need to put this in the OnTime queue otherwise never gets checked
    
    Dim bCancel As Boolean
    
    If moExec Is Nothing Then
        bCancel = True
    Else
        If moExec.Status <> WshRunning Then
            bCancel = True
        End If
    End If

    If bCancel Then
        mdicBackgroundTask("Cancel") = True
        Debug.Print "Process exited, request cancel"
    End If
End Sub

Sub SomeTaskToGetOnWith()
    DoEvents
    If mdicBackgroundTask("Cancel") = True Then
        Debug.Print "no more, cancel requested"
    Else
    
        If Not mdicBackgroundTask.Exists("TaskRun") Then
           
            mdicBackgroundTask("Started") = Now
            mdicBackgroundTask("TaskRun") = True
            
            '* ensure MaxSeconds has something sensible
            If Not mdicBackgroundTask.Exists("MaxSeconds") Then
                mdicBackgroundTask("MaxSeconds") = 1
            ElseIf mdicBackgroundTask("MaxSeconds") <= 0 Then
                mdicBackgroundTask("MaxSeconds") = 1
            End If
            
        End If
        
        Dim l As Long
        For l = 1 To 10
            
            Debug.Print Rnd()
        Next l
    
    
        '* some less simple logic to steop this task rescheduling forever
        If Abs(VBA.DateDiff("s", mdicBackgroundTask("Started"), Now())) <= mdicBackgroundTask("MaxSeconds") Then
        
            Application.OnTime Now(), "CheckForCancel"
            Application.OnTime Now(), "SomeTaskToGetOnWith"
            Debug.Print "rescheduled"
        Else
            Debug.Print "no more rescheduling done enough work, " & mdicBackgroundTask("MaxSeconds") & " seconds."
        End If
    
    End If
    
End Sub