VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsRunApp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'---------------------------------------------------------------------------------------
' Module    : clsRunApp
' DateTime  : 10/28/2009 11:43
' Author    : DMaruca
' Purpose   : Runs a shell process. You can build a command using Command and AddParamater.
'             Adding a new command clears any existing paramaters.
'
' Example   :
'    Dim cls As New clsRunApp
'    cls.Command = "c:\pdftotext.exe"
'    cls.AddParamater "-layout"
'    'Surrounding quotes will be auto added to this param since it has spaces.
'    'No more cluttery shell commands!
'    cls.AddParamater "C:\Data\PDF\CLTIC-AK-TR-09-01 NAIC Rate Rule Filing Schedule.pdf"
'    cls.AddParamater "C:\temp.txt"
'    cls.RunAppWait
'---------------------------------------------------------------------------------------
Option Explicit

'ERROR enumeration and base error number.
Private Const ErrorBase = 1000
Public Enum ErrorRunApp
    ApiFailure = ErrorBase
    BlankParamater 'Adding a blank paramater
    CommandNotFound_ShellCommand 'shell() error
    CommandPathNotFound 'Only if using CheckForCommandNotExist
    NoCommand 'Trying to run without a command
    UnhandledError 'Mysterious
End Enum

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

' STARTUPINFO flags
Private Const STARTF_USESHOWWINDOW = &H1
Private Const STARTF_USESTDHANDLES = &H100

' ShowWindow flag
Private Const SW_HIDE = 0

'Used by OpenProcess
Private Const PROCESS_QUERY_INFORMATION As Long = &H400
Private Const SYNCHRONIZE As Long = &H100000

'Used by GetExitCodeProcess
Private Const STILL_ACTIVE As Long = &H103

'Used by FormatMessage
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK As Long = &HFF
Private Const FormatMessageDwFlags = FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS Or FORMAT_MESSAGE_MAX_WIDTH_MASK

'Error code from VBA Shell()
Private Const ErrFileNotFound = 53

'CreatePipe buffer size
Private Const BUFSIZE = 1024


Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Private Type STARTUPINFO
    cb As Long
    lpReserved As Long
    lpDesktop As Long
    lpTitle As Long
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Long
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

Private Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type

Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreatePipe Lib "kernel32.dll" (ByRef phReadPipe As Long, ByRef phWritePipe As Long, ByRef lpPipeAttributes As SECURITY_ATTRIBUTES, ByVal nSize As Long) As Long
Private Declare Function CreateProcess Lib "kernel32.dll" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByRef lpProcessAttributes As SECURITY_ATTRIBUTES, ByRef lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByRef lpEnvironment As Any, ByVal lpCurrentDriectory As String, ByRef lpStartupInfo As STARTUPINFO, ByRef lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function FormatMessage Lib "kernel32.dll" Alias "FormatMessageA" (ByVal dwFlags As Long, ByRef lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByRef Arguments As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long
Private Declare Sub GetStartupInfo Lib "kernel32.dll" Alias "GetStartupInfoA" (ByRef lpStartupInfo As STARTUPINFO)
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function PeekNamedPipe Lib "kernel32.dll" (ByVal hNamedPipe As Long, ByRef lpBuffer As Any, ByVal nBufferSize As Long, ByRef lpBytesRead As Long, ByRef lpTotalBytesAvail As Long, ByRef lpBytesLeftThisMessage As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long

'# -------------------------------------------------------------------------#
'#  private variables                                                       #
'# -------------------------------------------------------------------------#
Private m_command As String
Private m_paramaters() As String
Private m_checkForCommandNotExist As Boolean
'

'# -------------------------------------------------------------------------#
'#  class constructors                                                      #
'# -------------------------------------------------------------------------#
Private Sub Class_Terminate()
    Erase m_paramaters
End Sub

'# -------------------------------------------------------------------------#
'#  errors                                                                  #
'# -------------------------------------------------------------------------#
'All errors are up front for you to see. This class will not throw any errors
'not found here or in the enum above.
Private Sub ErrorCheck_ApiFailure(proc As String, desc As String)
    Err.Raise Number:=vbObjectError + ErrorRunApp.ApiFailure, _
              Source:=proc, _
              Description:=desc
End Sub
Private Sub ErrorCheck_BlankParamater(proc As String, test As Boolean)
    If test Then Err.Raise Number:=vbObjectError + ErrorRunApp.BlankParamater, _
       Source:=proc, _
       Description:="The paamater is blank."
End Sub
Private Sub ErrorCheck_CommandNotFound_ShellCommand(proc As String)
    Err.Raise Number:=vbObjectError + ErrorRunApp.CommandNotFound_ShellCommand, _
              Source:=proc, _
              Description:="The command specified was not found."
End Sub
Private Sub ErrorCheck_CommandPathNotFound(proc As String, test As Boolean)
    If test Then Err.Raise Number:=vbObjectError + ErrorRunApp.CommandPathNotFound, _
       Source:=proc, _
       Description:="The path specified does not exist."
End Sub
Private Sub ErrorCheck_NoCommand(proc As String, test As Boolean)
    If test Then Err.Raise Number:=vbObjectError + ErrorRunApp.NoCommand, _
       Source:=proc, _
       Description:="No command specified."
End Sub
Private Sub ErrorCheck_UnhandledError(proc As String, Error As ErrObject)
    Err.Raise Number:=Error.Number, _
              Source:=proc, _
              Description:=Error.Description
End Sub

'# -------------------------------------------------------------------------#
'#  properties                                                              #
'# -------------------------------------------------------------------------#
Public Property Let command(path As String)
    If CheckForCommandNotExist Then
        ErrorCheck_CommandPathNotFound "Command", Not FileExists(path)
    End If
    
    m_command = path
    Erase m_paramaters
End Property

Public Property Get command() As String
    command = m_command
End Property

Public Property Get CheckForCommandNotExist() As Boolean
    CheckForCommandNotExist = m_checkForCommandNotExist
End Property

Public Property Let CheckForCommandNotExist(ByVal val As Boolean)
    m_checkForCommandNotExist = val
End Property

'# -------------------------------------------------------------------------#
'#  methods                                                                 #
'# -------------------------------------------------------------------------#

'---------------------------------------------------------------------------------------
' Procedure : AddParamater
' Purpose   : Adds a paramater.
'             Quote handling is based on the fact that many cmd's will fail if file
'             paramaters are not surrounded by quotes *IF* they have a space in the file
'             name or path.
'             eQuote_Normal will correct this.
'             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.
' Errors    : BlankParamater
'---------------------------------------------------------------------------------------
'
Public Sub AddParamater(paramater As String, Optional ForceQuotes As eQuote = eQuote_Normal)
    Const vbQuote = """"
    Dim AddQuotes As Boolean

    ErrorCheck_BlankParamater "AddParamater", (paramater = "")

    ReDim Preserve m_paramaters(1 To ParamaterCount + 1) As String

    If ForceQuotes = eQuote_ForceQuotes Then
        AddQuotes = True
    ElseIf ForceQuotes = eQuote_ForceNone Then
        AddQuotes = False
    Else    ' eQuote_Normal
        If InStr(1, paramater, " ") > 0 Then AddQuotes = True
    End If

    If AddQuotes Then
        m_paramaters(ParamaterCount) = Space(Len(paramater) + 2)
        Mid(m_paramaters(ParamaterCount), 1, 1) = vbQuote
        Mid(m_paramaters(ParamaterCount), Len(m_paramaters(ParamaterCount)), 1) = vbQuote
        Mid(m_paramaters(ParamaterCount), 2, Len(paramater)) = paramater
    Else
        m_paramaters(ParamaterCount) = paramater
    End If
End Sub

'---------------------------------------------------------------------------------------
' Procedure : ErrNum
' Purpose   : Returns the error number for the enumerated error at run-time.
' Errors    : None
'---------------------------------------------------------------------------------------
'
Public Function ErrNum(Error As ErrorRunApp)
    ErrNum = vbObjectError + Error
End Function

'---------------------------------------------------------------------------------------
' Procedure : RunApp
' Purpose   : Run an application, returning immediately to the caller.
' Errors    : CommandNotFound_ShellCommand, UnhandledError
'---------------------------------------------------------------------------------------
'
Public Sub RunApp(Optional cmd As String, Optional intMode As VbAppWinStyle = VbAppWinStyle.vbHide)
    On Error GoTo errHandler
    Dim hInstance As Long
    Dim m_command As String

    If cmd <> "" Then
        m_command = cmd
    Else
        m_command = BuildCommand
    End If

    hInstance = shell(m_command, intMode)

exitRoutine:
    Exit Sub
errHandler:
    Select Case Err.Number
        Case ErrFileNotFound
            ErrorCheck_CommandNotFound_ShellCommand "RunApp"
        Case Else
            ErrorCheck_UnhandledError "RunApp", Err
    End Select
    Resume exitRoutine
End Sub

'---------------------------------------------------------------------------------------
' Procedure : RunAppWait
' Purpose   : Run an application, waiting for its completion before returning to the caller.
' Errors    : CommandNotFound_ShellCommand, ApiFailure, UnhandledError
'---------------------------------------------------------------------------------------
'
Public Sub RunAppWait(Optional cmd As String, Optional intMode As VbAppWinStyle = VbAppWinStyle.vbHide)
    On Error GoTo errHandler
    Dim hInstance As Long
    Dim hProcess As Long
    Dim lngRetval As Long
    Dim lngExitCode As Long
    Dim m_command As String
    Dim ErrorDesc As String

    If cmd <> "" Then
        m_command = cmd
    Else
        m_command = BuildCommand
    End If

    hInstance = shell(m_command, intMode)

    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or SYNCHRONIZE, True, hInstance)
    If ApiErrorChecker("OpenProcess", hProcess, Err.LastDllError, ErrorDesc) Then
        ErrorCheck_ApiFailure "RunAppWait", ErrorDesc
    End If

    Do
        lngRetval = GetExitCodeProcess(hProcess, lngExitCode)
        If ApiErrorChecker("GetExitCodeProcess", lngRetval, Err.LastDllError, ErrorDesc) Then
            ErrorCheck_ApiFailure "RunAppWait", ErrorDesc
        End If
        DoEvents
    Loop Until lngExitCode <> STILL_ACTIVE

exitRoutine:
    Exit Sub
errHandler:
    Select Case Err.Number
        Case ErrFileNotFound
            ErrorCheck_CommandNotFound_ShellCommand "RunAppWait"
        Case Else
            'ApiFailure will detour through here, but will still return the correct #
            ErrorCheck_UnhandledError "RunAppWait", Err
    End Select
    Resume exitRoutine
End Sub

'---------------------------------------------------------------------------------------
' Procedure : RunAppWait_CaptureOutput
' Purpose   : Runs an application, waiting for its completion before returning to the
'             caller. Screen output is captured and returned to the caller.
' Errors    : ApiFailure, UnhandledError
'---------------------------------------------------------------------------------------
'
Public Function RunAppWait_CaptureOutput(Optional cmd As String) As String
    On Error GoTo errHandler
    Dim pa As SECURITY_ATTRIBUTES
    Dim pra As SECURITY_ATTRIBUTES
    Dim tra As SECURITY_ATTRIBUTES
    Dim si As STARTUPINFO
    Dim pi As PROCESS_INFORMATION
    Dim retVal As Long
    Dim command As String
    Dim ErrorDesc As String
    Dim hRead As Long     ' stdout + stderr
    Dim hWrite As Long
    Dim bAvail As Long    ' pipe bytes available (PeekNamedPipe)
    Dim bRead As Long     ' pipe bytes fetched   (ReadFile)
    Dim bString As String    ' our buffer

    If cmd <> "" Then
        command = cmd
    Else
        command = BuildCommand
    End If

    pa.nLength = Len(pa)
    pa.bInheritHandle = 1

    pra.nLength = Len(pra)
    tra.nLength = Len(tra)

    retVal = CreatePipe(hRead, hWrite, pa, BUFSIZE)
    If ApiErrorChecker("CreatePipe", retVal, Err.LastDllError, ErrorDesc) Then
        ErrorCheck_ApiFailure "RunAppWait_CaptureOutput", ErrorDesc
    End If

    With si
        .cb = Len(si)
        GetStartupInfo si
        .dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES
        .wShowWindow = SW_HIDE
        .hStdOutput = hWrite
        .hStdError = hWrite
    End With

    pra.bInheritHandle = 0
    tra.bInheritHandle = 0
    retVal = CreateProcess(vbNullString, command, pra, tra, 1, 0&, ByVal 0&, vbNullString, si, pi)
    If ApiErrorChecker("CreateProcess", retVal, Err.LastDllError, ErrorDesc) Then
        CloseHandle hWrite
        CloseHandle hRead
        ErrorCheck_ApiFailure "RunAppWait_CaptureOutput", ErrorDesc
    End If

    Do While PeekNamedPipe(hRead, ByVal 0, 0, ByVal 0, bAvail, ByVal 0)
        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
        End If
    Loop
    CloseHandle hRead
    CloseHandle pi.hThread
    CloseHandle pi.hProcess

exitRoutine:

    Exit Function
errHandler:
    Select Case Err.Number
        Case Else
            'ApiFailure will detour through here, but will still return the correct #
            ErrorCheck_UnhandledError "RunAppWait_CaptureOutput", Err
    End Select
    Resume exitRoutine
End Function

'# -----------------------------------------------------------------------------#
'#   private routines                                                           #
'# -----------------------------------------------------------------------------#

'---------------------------------------------------------------------------------------
' Procedure : ApiErrorChecker
' Purpose   : Follows the convention that api's have failed if they return NULL (0).
'             If the api returned an error code it will format an error message and
'             return true. Gets error messages from FormatMessage api.
' Errors    : None
'---------------------------------------------------------------------------------------
'
Private Function ApiErrorChecker(ApiName As String, ReturnCode As Long, ErrorCode As Long, ByRef ErrorDesc As String) As Boolean
    Const MaxBuf = 260
    Dim lngRetval As Long

    'The api did not fail
    If ReturnCode > 0 Then Exit Function

    If ErrorCode = 0 Then
        'The api failed but no error given...
        'We can assume no error?
        Exit Function
    Else
        ErrorDesc = Space(MaxBuf)
        lngRetval = FormatMessage(FormatMessageDwFlags, 0&, ErrorCode, 0&, ErrorDesc, Len(ErrorDesc), 0&)
        ErrorDesc = Left$(ErrorDesc, lngRetval)
        ErrorDesc = Replace(ApiName & " exited with error code({0}): " & ErrorDesc, "{0}", ErrorCode)
    End If
    ApiErrorChecker = True
End Function

'---------------------------------------------------------------------------------------
' Procedure : BuildCommand
' Purpose   : Returns the command with any paramaters attached to the end.
' Errors    : NoCommand
'---------------------------------------------------------------------------------------
'
Private Function BuildCommand() As String
    Dim length As Long
    Dim s As String

    ErrorCheck_NoCommand "BuildCommand", (command = "")

    If ParamaterCount = 0 Then
        length = Len(command)
    Else
        s = BuildParamaters
        length = Len(command) + Len(s) + 1
    End If

    BuildCommand = Space(length)

    Mid(BuildCommand, 1, Len(command)) = command

    If s <> "" Then Mid(BuildCommand, Len(command) + 2, Len(s)) = s
End Function

'---------------------------------------------------------------------------------------
' Procedure : BuildParamaters
' Purpose   : Returns paramaters with spaces in between or a null string if no paramaters.
' Errors    : None
'---------------------------------------------------------------------------------------
'
Private Function BuildParamaters() As String
    Dim length As Long
    Dim s As Variant

    If ParamaterCount = 0 Then
        BuildParamaters = ""
        Exit Function
    End If

    For Each s In m_paramaters
        length = length + Len(s)
    Next

    If ParamaterCount > 1 Then length = length + ParamaterCount - 1

    BuildParamaters = Space(length)

    length = 1
    For Each s In m_paramaters
        Mid(BuildParamaters, length, Len(s)) = s
        length = length + Len(s) + 1
    Next
End Function

'---------------------------------------------------------------------------------------
' Procedure : FileExists
' Purpose   : Uses windows API to determine if the file (or folder) exists.
' Errors    : None
'---------------------------------------------------------------------------------------
'
Private Function FileExists(path As String) As Boolean
    FileExists = PathFileExists(path)
End Function

'---------------------------------------------------------------------------------------
' Procedure : ParamaterCount
' Purpose   : Returns the number of paramaters stored. m_paramaters() is base 1
' Errors    : None
'---------------------------------------------------------------------------------------
'
Private Function ParamaterCount() As Long
    On Error GoTo errHandler

    ParamaterCount = UBound(m_paramaters)

exitRoutine:
    Exit Function
errHandler:
    Err.Clear
    Resume exitRoutine
End Function