[VBA] Run Application - Capture Output-VBForums
Results 1 to 4 of 4

Thread: [VBA] Run Application - Capture Output

  1. #1

    Thread Starter
    Fanatic Member dmaruca's Avatar
    Join Date
    May 2006
    Jacksonville, FL

    [VBA] Run Application - Capture Output

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

    The first 2 routines use shell().
    vb Code:
    1. 'Run an application, returning immediately to the caller.
    2. Public Sub RunApp(Optional cmd As String, Optional intMode As VbAppWinStyle = _
    3.     VbAppWinStyle.vbHide)
    4. 'Run an application, waiting for its completion before returning to the caller.
    5. Public Sub RunAppWait(Optional cmd As String, Optional intMode As VbAppWinStyle = _
    6.     VbAppWinStyle.vbHide)

    The next routine uses api.
    vb Code:
    1. 'Runs an application, waiting for its completion before returning to the caller.
    2. 'Screen output is captured and returned to the caller.
    3. 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.
    vb Code:
    1. Sub ExtractTextDirect()
    2.     Dim cls As New clsRunApp
    3.     Dim s as String
    5.     cls.Command = "C:\Path To\pdftotext.exe"
    6.     cls.AddParamater "-layout" 'preserve the layout of the text
    7.     'Surrounding quotes will be auto-added to this paramater since it has spaces.
    8.     cls.AddParamater "C:\super long path to pdf file\my pdf file.pdf"
    9.     'a hyphen as the next paramater directs output to stdout which we will capture
    10.     cls.AddParamater "-"
    12.     s = cls.RunAppWait_CaptureOutput
    13.     Set cls = Nothing
    15. 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
    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.

    vb Code:
    1. cls.CheckForCommandNotExist = True
    2. cls.Command = "pdftotext.exe" 'ERROR
    3. cls.Command = "C:\Path To\pdftotext.exe" 'Yes
    5. 'Ignore built in command builder. The stored command still exists.
    6. 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.

    vb Code:
    1. Sub ErrorTest()
    2.     Dim cls As New clsRunApp
    4.     On Error Resume Next
    5.     cls.CheckForCommandNotExist = True
    6.     cls.command = "c:\pdftotext.exe"
    7.     If Err.Number = cls.ErrNum(CommandPathNotFound) Then
    8.         MsgBox "pdtotext is not found"
    9.     End If
    12.     MsgBox cls.RunAppWait_CaptureOutput("klsdj /?")
    13.     If Err.Number = cls.ErrNum(ApiFailure) Then
    14.         MsgBox Replace("Api failure in {0}! ", "{0}", Err.Source) & Err.Description
    15.     End If
    17.     'I thought this was cute.
    18.     MsgBox cls.RunAppWait_CaptureOutput("cmd /C echo Test complete.")
    19. 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.
    Attached Files Attached Files
    Last edited by dmaruca; Nov 14th, 2012 at 03:07 PM.

  2. #2

    Thread Starter
    Fanatic Member dmaruca's Avatar
    Join Date
    May 2006
    Jacksonville, FL

    Re: [VBA] Run Application - Capture Output

    Edit: Bugfix if anyone is subscribed to this thread.

  3. #3
    New Member
    Join Date
    Mar 2011

    Re: [VBA] Run Application - Capture Output

    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!

  4. #4

    Thread Starter
    Fanatic Member dmaruca's Avatar
    Join Date
    May 2006
    Jacksonville, FL

    Re: [VBA] Run Application - Capture Output

    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\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 
        On Error Resume Next
        Set RunApp = Nothing
        Exit Function
        Resume exitProcedure
    End Function
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts


Click Here to Expand Forum to Full Width

Survey posted by VBForums.