VBA - Shell a process and acquire its StdIn, StdOut, StdErr pipes

Juts a quickie. On Stackoverflow some code posted which shells a process and reads the piped output purely using Window API calls, quite impressive but seems to be tripping up on some 64-bit issue. Actually VBA developers need not wrestle Windows API on this one and can in fact use the Windows Script Host Object Model library instead.

Option Explicit

Function ShellAndGetText() As String

    '* Tools -> References
    '* Windows Script Host Object Model

    Dim oWshShell As IWshRuntimeLibrary.WshShell
    Set oWshShell = New IWshRuntimeLibrary.WshShell


    Dim oWshExec As IWshRuntimeLibrary.WshExec
    
    Dim sComSpec As String
    sComSpec = Environ$("COMSPEC")
    
    Dim sReturnText As String
    Set oWshExec = oWshShell.Exec(sComSpec & " foo.exe")
    
    While oWshExec.Status = WshRunning
        DoEvents
    Wend
    If oWshExec.Status = WshFinished Then
        '* success
        sReturnText = oWshExec.StdOut
    Else
        '* failure
        sReturnText = oWshExec.StdErr
    End If

    ShellAndGetText = sReturnText

End Function

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