[VBA] Run Application - Capture Output

[dmaruca]

This class includes 3 routines for shelling a program in Windows and an optional command-line builder.

The first 2 routines use shell().

'Run an application, returning immediately to the caller.
Public Sub RunApp(Optional cmd As String, Optional intMode As VbAppWinStyle = _
    VbAppWinStyle.vbHide)
'Run an application, waiting for its completion before returning to the caller.
Public Sub RunAppWait(Optional cmd As String, Optional intMode As VbAppWinStyle = _
    VbAppWinStyle.vbHide)

The next routine uses api.

'Runs an application, waiting for its completion before returning to the caller. 
'Screen output is captured and returned to the caller.
Public Function RunAppWait_CaptureOutput(Optional cmd As String) As String

The optional command-line builder can be explained using this example. I like to use this a lot for pdftotex.exe. This example shows you how to extract the text from a pdf file without using an intermediate text file. It is FIFO.

Sub ExtractTextDirect()
    Dim cls As New clsRunApp
    Dim s as String
    
    cls.Command = "C:\Path To\pdftotext.exe"
    cls.AddParamater "-layout" 'preserve the layout of the text
    'Surrounding quotes will be auto-added to this paramater since it has spaces.
    cls.AddParamater "C:\super long path to pdf file\my pdf file.pdf"
    'a hyphen as the next paramater directs output to stdout which we will capture
    cls.AddParamater "-" 
    
    s = cls.RunAppWait_CaptureOutput
    Set cls = Nothing
    
End Function

A note about the auto adding of quotes to paramaters: AddParamater has an optional paramater for using quotes. The default behavior will add quotes around paramaters with spaces, but not add any around paramaters without spaces.

'Use by AddParamater. See procedure header for explanation.
Public Enum eQuote
    eQuote_Normal
    eQuote_ForceNone
    eQuote_ForceQuotes
End Enum

eQuote_Normal is discussed above.
eQuote_ForceNone is for if your paramater has spaces but you do not want it surrounded by quotes.
    Useful for switches like -f 37.
eQuote_ForceQuotes surrounds the paramater with quotes no matter what.

So if you lump all your switches in one statement use this:
cls.AddParamater "-o -f 37 -g", eQuote_ForceNone

The class also has an optional flag for checking if the command exists when you assign it to the Command property. This is useful only if you want your code to fail on the command assignment. Only use this if you provide the full path to the command.

cls.CheckForCommandNotExist = True
cls.Command = "pdftotext.exe" 'ERROR
cls.Command = "C:\Path To\pdftotext.exe" 'Yes
 
'Ignore built in command builder. The stored command still exists.
MsgBox cls.RunAppWait_CaptureOutput("netstat /?")

I've included plenty of built-in error checking and documentationin the class file. Check it out if you want.

Sub ErrorTest()
    Dim cls As New clsRunApp
    
    On Error Resume Next
    cls.CheckForCommandNotExist = True
    cls.command = "c:\pdftotext.exe"
    If Err.Number = cls.ErrNum(CommandPathNotFound) Then
        MsgBox "pdtotext is not found"
    End If
    
    
    MsgBox cls.RunAppWait_CaptureOutput("klsdj /?")
    If Err.Number = cls.ErrNum(ApiFailure) Then
        MsgBox Replace("Api failure in {0}! ", "{0}", Err.Source) & Err.Description
    End If
    
    'I thought this was cute.
    MsgBox cls.RunAppWait_CaptureOutput("cmd /C echo Test complete.")
End Sub

You have probably seen these floating around, but I use these routines so often I finally decided to combine them in one place and wrap them in a class with a built-in command builder. Maybe you'll find it useful.

Edit 2-3-2010:
A bug was discovered in the CreateProcess call inside RunAppWait_CaptureOutput. This has been repaired.

Edit 11-14-2012
Modified to work with xcopy and other programs which require stdin. The copy attached to this post will not work with xcopy. See the update post here.

[dmaruca]

Edit: Bugfix if anyone is subscribed to this thread.

[brad.perrin]

This is very helpful. I am an accountant, trying to tie together various open source command line utilities to improve our firms document management processes. This gets me much closer to my goal!

[dmaruca]

I updated this to work with xcopy. It was failing before because xcopy requires stdin to run. I've also renamed it to CRunApp but works the same as the previous.

Note: Since this opens up stdin, exe's which prompt for information will put the program into an infinite blocking state waiting for input. Make sure you put the correct switches in place to prevent any prompting. I'm sure this could be modified to accommodate this prompting and even extended to be fully interactive with a console application. To do that you would use WriteFile to write to the hWriteIn handle.

Looking at old code can sometimes cause me to wince. My style has changed over the years and I have become more experienced with working with API calls. My initial reaction from looking at this is to rewrite it, but it has been running production in so many of my projects for years with no errors I figure why fix what's not broken.

Here is an example of calling xcopy with this class:

Sub TestCopyFolder()
	Debug.Print CopyFolder("C:\test folder 1\*", "C:\test folder 2\")
End Sub

Public Function CopyFolder(SourceWithMask As String, DestinationWithoutMask As String, Optional CopySubdirectories As Boolean = True) As Boolean
    Dim RunApp As New CRunApp
    Dim s As String

    With RunApp
        .Command = "cmd.exe /c xcopy.exe"
        .AddParamater "/Q" 'Does not display file names while copying. (this prevents false positives with files name "File(s) copied.txt")
        .AddParamater "/R" 'Overwrites read-only files.
        .AddParamater "/Y" 'Suppresses prompting to confirm you want to overwrite an existing destination file.
        .AddParamater "/I" 'If destination does not exist and copying more than one file, assumes that destination must be a directory.
        .AddParamater "/G" 'Allows the copying of encrypted files to destination that does not support encryption.
        If CopySubdirectories Then
            .AddParamater "/E" 'Copies directories and subdirectories, including empty ones.
        End If
        .AddParamater SourceWithMask
        .AddParamater DestinationWithoutMask
        s = .RunAppWait_CaptureOutput
    End With

    CopyFolder = InStr(1, s, "File(s) copied") > 1
End Function

I've also added a "CurrentDirectory" parameter which is useful for acting like the command was called from the provided directory. This is useful for creating zip files which have root directories. Here's an example using 7-zip:

Sub TestCreateZip()
	'Given path "c:\folder to zip\subfolder\*.*" 
	'This will create a zip file with a root directory "subfolder" inside the zip file. 
	'The zip file will contain:
	'subfolder\file1.txt
	'subfolder\subfolder2\file2.txt etc etc
	Debug.Print CreateZip(FullZipPath:="C:\New Zip File.zip", _
		FromFolder:="subfolder\*", _
		CurrentDirectory:="c:\folder to zip\")
End Sub

Public Function CreateZip(FullZipPath As String, FromFolder As String, Optional Password, Optional CurrentDirectory As String) As Boolean
    Dim RunApp As New CRunApp
    Dim s As String
    
On Error GoTo errHandler

    With RunApp
        .Command = "C:\7z.exe"
        .AddParamater "a" 'add files switch
        .AddParamater "-aoa" 'Overwrite All existing files without prompt.
        .AddParamater "-y" 'assume yes on all queries
        If Not IsMissing(Password) Then
            .AddParamater "-p" & CStr(Password), eQuote_ForceNone  'you should probably enclose the password in quotes if it has a space
            .AddParamater "-mhe" 'encrypts archive headers 
        End If
        .AddParamater "--" 'prevent further switch parsing
        .AddParamater FullZipPath 'the zip
        .AddParamater FromFolder 'the path/wildcard of the files
        s = .RunAppWait_CaptureOutput(CurrentDirectory:=CurrentDirectory)
    End With

    CreateZip = InStr(1, s, "Everything is Ok", vbTextCompare) > 0 
exitProcedure:
    On Error Resume Next
    Set RunApp = Nothing
    Exit Function
errHandler:
    Resume exitProcedure
    Resume
End Function

[VBF_ABZ]

Hi,

It's been a while since this post but I hope you're still around on the forums.

Firstly, thanks for providing this helpful class.

There is a slight wrinkle when capturing output. I thought I should provide feedback to allow the class to be improved.

The wrinkle concerns the case where a command has no output. The command I'm running only produces output if there's something to report, otherwise it reports nothing. [It's the Subversion command "svn status".]

If the command has no output the PeekNamedPipe loop never exits. A simple example of a command that generates no output and simply teminates is "type nul". The following code can be used to run that command with your class:

Public Function TestRunApp() As String
    Dim cmd_output As String
    Dim RunApp As New CRunApp

    cmd_output = ""
    
    With RunApp
        .Command = "cmd.exe /c type"
        .AddParamater "nul"
        cmd_output = .RunAppWait_CaptureOutput
    End With

    TestRunApp = cmd_output
End Function

Calling this code will result in the RunAppWait_CaptureOutput method never exiting as it is stuck in an endless loop.

I'd speculate that the pipe doesn't close because nothing was sent through it. The solution is to also check whether the process is still running and allow the loop to also end in that case.

The following code would fix the issue:

capture_complete = False  ' We haven't even started yet
process_running = True    ' Assume it's running, it'll be rechecked later

Do While Not capture_complete
    If PeekNamedPipe(hRead, ByVal 0, 0, ByVal 0, bAvail, ByVal 0) = 0 Then
        capture_complete = True  ' The pipe peek failed (probably closed)
    Else
    
        DoEvents
        If bAvail Then
            bString = String(bAvail, 0)
            ReadFile hRead, bString, bAvail, bRead, ByVal 0&
            bString = Left(bString, bRead)
            RunAppWait_CaptureOutput = RunAppWait_CaptureOutput & bString
            CloseHandle hWrite
        
        ElseIf Not process_running Then
            capture_complete = True  ' The process previously finished and nothing in pipe so stop capturing
        
        Else
            lngRetval = GetExitCodeProcess(pi.hProcess, lngExitCode)
            If ApiErrorChecker("GetExitCodeProcess", lngRetval, Err.LastDllError, ErrorDesc) Then
                ErrorCheck_ApiFailure "RunAppWait", ErrorDesc
            End If
            
            If lngExitCode <> STILL_ACTIVE Then
                ' N.B. Do not exit the loop immediately, set a flag but ensure that the pipe is checked again
                ' as something may have been added to the pipe since the last check, but prior to the process
                ' termination
                process_running = False
            End If
        
            DoEvents  ' Process events before peeking at the pipe again
        End If
    End If
Loop

No doubt, this code might benefit from a little tidy-up but I hope it demonstrates the solution.

I'm still researching this, trying to determine the order of events, at process termination, that is guaranteed. For example, when the process terminates it seems reasonable that the pipe is still active (to allow the remaining content to be read from the connected process). However, could the process be detected as terminated before the command output was available in the pipe? This would be dangerous for this class, since the pipe would need to continue to be checked after the process terminates, but for how long. It seems to me that the time would be arbitary. As it stands, the changes I've described ensure that the pipe will be checked at least 1 more time after the process is detected as terminated. This should ensure that the pipe is flushed before the loop exits.

Alternatively, the documentation suggests that the pipe is closed on the termination of the process. If that is the case, what happens if we haven't got around to reading the pipe contents prior to termination? How quick does the reading process need to be?

BTW, I note that there is no reference to a license for your class. Are you happy for it to be freely used? If so, a comment in the class header would be helpful.

Regards.

[dmaruca]

Hi there. There is no license associated with this code. Do whatever you wish with it.

I've primarily used this class to do pdf to text conversions and 7zip over the years. I've used it for other things here and there. In my experience once the output is done the process is finished, but I'm sure there are programs written out there that could break this.

Thanks for posting your update.

[VBF_ABZ]

Hi,

There is no license associated with this code. Do whatever you wish with it.

Thanks for the confirmation.

In my experience once the output is done the process is finished,...

The problem is actually the reverse of this. That is, the process is finished but the (empty) output isn't considered done, so the code waits forever in an endless loop.

Thanks for posting your update.

No problem. It's the least I could do.

Regards.

[Azev]

Hello!

On Office 2013 it is giving me the message:

Run-time error '-2147220504 (800403e8)':

CreatePipe exited with error code(998): Invalid access to memory location.

[bluenote]

Would also like to see a 2013 version of this, I get a 800403e8 automation error. Thanks for any pointers.

[dmaruca]

Hi guys. Sorry, I did not see the message from November. I just tested in my copy of 2013 and it works fine. What version specifically are you using and what command are you trying to run that gives the error? It sounds like the error lies with the API instead of the version of office.

[bluenote]

Hi guys. Sorry, I did not see the message from November. I just tested in my copy of 2013 and it works fine. What version specifically are you using and what command are you trying to run that gives the error? It sounds like the error lies with the API instead of the version of office.

Thanks for getting back It fails even if I try your netstat /? example.
My VBA (excel 2013) reports VBA 7.1 / Version 1042 7.1.1042

I'm importing your CLS, adding 'ptrsafe' liberally where VBA complains, and then doing:

Dim cls As New clsRunApp

cls.command = "netstat /?"
MsgBox cls.RunAppWait_CaptureOutput("netstat /?")

I may well be doing something stupid, I'm the first to admit I don't understand this very well.
thx

[dmaruca]

I'll try to get to a 64 bit version sometime soon. you have to do more than pointer safe. every pointer has to be a longptr

[bluenote]

I'll try to get to a 64 bit version sometime soon. you have to do more than pointer safe. every pointer has to be a longptr

Thanks. In the meantime I've converted to this:

cmd = "ipconfig /all"
Dim objShell, objCmdExec
Set objShell = CreateObject("WScript.Shell")
Set objCmdExec = objShell.exec(cmd)
CommandOutput = objCmdExec.StdOut.ReadAll

[jgfcoimbra]

Hi dmaruca,

Any chance to have the 64 bit version of this code please? We recently moved from 32 bit to 64 bit laptops and the script that was initially working perfectly is no longer working.

Many thanks,
Joao