[VBA] Run Application - Capture Output

[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