Untitled

Option Explicit

Private Declare Function GetExitCodeProcess Lib "kernel32.dll" ( _
    ByVal hProcess As Long, _
    lpExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" ( _
    ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" ( _
    ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" ( _
    ByVal hHandle As Long, _
    ByVal dwMilliseconds As Long) As Long
Private Declare Function GetLastError Lib "kernel32.dll" () As Long
Private Declare Function FormatMessage Lib "kernel32.dll" Alias "FormatMessageA" ( _
    ByVal dwFlags As Long, _
    lpSource As Any, _
    ByVal dwMessageId As Long, _
    ByVal dwLanguageId As Long, _
    ByVal lpBuffer As String, _
    ByVal nSize As Long, _
    Arguments As Any) As Long

' Basic access rights
Private Const DELETE_ = &H10000 ' renamed from DELETE (as the latter is a reserved word)
Private Const READ_CONTROL = &H20000
Private Const WRITE_DAC = &H40000
Private Const WRITE_OWNER = &H80000
Private Const SYNCHRONIZE = &H100000

' Standard access rights
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const STANDARD_RIGHTS_READ = READ_CONTROL
Private Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Private Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Private Const STANDARD_RIGHTS_ALL = &H1F0000

' Process specific rights
Private Const PROCESS_TERMINATE = &H1
Private Const PROCESS_CREATE_THREAD = &H2
Private Const PROCESS_SET_SESSIONID = &H4
Private Const PROCESS_VM_OPERATION = &H8
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_VM_WRITE = &H20
Private Const PROCESS_DUP_HANDLE = &H40
Private Const PROCESS_CREATE_PROCESS = &H80
Private Const PROCESS_SET_QUOTA = &H100
Private Const PROCESS_SET_INFORMATION = &H200
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const PROCESS_SUSPEND_RESUME = &H800
Private Const PROCESS_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF

' Process ID constants
Private Const SILL_RUNNING = &H103

' Synchronization constants
Private Const INFINITE = -1 ' changed from 0xFFFFFFFF
Private Const WAIT_ABANDONED = &H80
Private Const WAIT_OBJECT_0 = &H0
Private Const WAIT_TIMEOUT = &H102
Private Const WAIT_FAILED = -1 ' changed from 0xFFFFFFFF

' Error message formatting constants
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF


' Returns the localized error message associated with ErrCode

Private Function GetErrorMessage(ByVal ErrCode As Long) As String
    Const BufSize = 1024
    Dim Buf As String
    Dim Res As Long
    
    Buf = String$(BufSize, 0)
    Res = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, ByVal 0&, ErrCode, 0, Buf, BufSize, ByVal 0&)
    If Res > 0 Then
        Buf = Left$(Buf, Res)
    Else
        Err.Raise vbObjectError, Description:= _
            "Error obtaining system error message for error code 0x" & _
            Hex$(ErrCode) & _
            " (return code: 0x" & _
            Hex$(GetLastError()) & _
            ")"
    End If
    
    GetErrorMessage = Buf
End Function


' Returns the localized error message associated with the last error that
' occurred (as returned by the GetLastError() function)

Private Function GetLastErrorMessage() As String
    GetLastErrorMessage = GetErrorMessage(GetLastError())
End Function


' Executes the specified CmdLine and returns the exit code of the process

Private Function ExecCommand(CmdLine As String) As Long
    Dim ProcID As Long
    Dim ProcHandle As Long
    Dim WaitRes As Long
    
    ProcID = Shell(CmdLine)
    ProcHandle = OpenProcess(PROCESS_QUERY_INFORMATION Or SYNCHRONIZE, False, ProcID)
    If ProcHandle = 0 Then
        Err.Raise vbObjectError, Description:=GetLastErrorMessage()
    End If
    Select Case WaitForSingleObject(ProcHandle, INFINITE)
        Case WAIT_OBJECT_0
            ' Do nothing - the process ended
        Case WAIT_FAILED
            Err.Raise vbObjectError, Description:=GetLastErrorMessage()
        Case Else ' WAIT_ABANDONED, WAIT_TIMEOUT
            ' These shouldn't be possible
            Debug.Assert False
    End Select
    If GetExitCodeProcess(ProcHandle, ExecCommand) = 0 Then
        Err.Raise vbObjectError, Description:=GetLastErrorMessage()
    End If
    CloseHandle ProcHandle
End Function