VBA - Using Application.OnTime to mimic multitasking

I saw someone else's blog today that launched a process and checked the error code to see when it terminates, they suggested waiting between each check. We can do better than that. We can schedule snippets of work using Application.OnTime which can reschedule themselves to keep going.

But we need to know when to stop, so we need a Cancel checking routine, it turns out you'll need to check the cancel also in a procedure scheduled with OnTime. Only when OnTime scheduled procedures have been exhausted does control return to the "normal" code.

This is actually better described as timeslicing, since VBA is single threaded. Using this technique, we can give the illusion of multiple tasks going on. This is fine because all the user really cares about is a responsive GUI.

Option Explicit

Private Declare Function OpenProcess Lib "kernel32" _
            (ByVal dwDesiredAccess As Long, _
            ByVal bInheritHandle As Long, _
            ByVal dwProcessId As Long) As Long
            
Private Declare Function CloseHandle Lib "kernel32" _
            (ByVal hObject As Long) As Long

Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
                    (ByVal hProcess As LongPtr, lpExitCode As Long) As Long

Private mdicBackgroundTask As New Scripting.Dictionary

Sub LaunchNotePadAndDoBackgroundWork()
    Dim hProg As Long
    Dim hProc As Long
    Const PROCESS_ALL_ACCESS As Long = &H0
    Const SYNCHRONIZE As Long = &H100000
    Const PROCESS_QUERY_LIMITED_INFORMATION As Long = &H1000
    Const INFINITE As Long = &HFFFF
    'hProg = Shell(Environ("comspec") & " /s /c notepad.exe ")
    hProg = Shell("notepad.exe", vbNormalFocus)

        
    
    hProc = OpenProcess(SYNCHRONIZE + PROCESS_QUERY_LIMITED_INFORMATION, False, hProg)
    If hProc > 0 Then
        '* delete the dictionary resets the state
        Set mdicBackgroundTask = Nothing
        
        mdicBackgroundTask("MaxSeconds") = 5
        mdicBackgroundTask("hProc") = hProc
        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"
        CloseHandle hProc
    End If
    
    DoEvents
End Sub

Sub CheckForCancel()
    '* seems that we need to put this in the OnTime queue otherwise never gets checked
    Dim lRetVal As Long
    GetExitCodeProcess mdicBackgroundTask("hProc"), lRetVal
    If lRetVal = 0 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