CShellProg.cls

Option Explicit

'
' CShellProg.cls
'

' Wait return codes
Private Const WAIT_OBJECT_0 = &H0&
Private Const WAIT_TIMEOUT = &H102&
Private Const WAIT_IO_COMPLETION = &HC0&
Private Const WAIT_ABANDONED = &H80&
Private Const WAIT_FAILED = &HFFFFFFFF

' Returned by getexitcodeprocess (not used)
Private Const STILL_ACTIVE = &H103&

' OpenProcess flags
Private Const PROCESS_QUERY_INFORMATION = &H400&
Private Const PROCESS_TERMINATE = &H1&
Private Const SYNCHRONIZE = &H100000
Private Const INVALID_HANDLE_VALUE = 0&

' APIs
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

' Possible process statuses
Public Enum ProcStatus
    psNone
    psRunning
    psTerminated
    psAborted
End Enum

' feedback events
Public Event Started(ByVal dwPID As Long, ByVal hProcess As Long)
Public Event Running()
Public Event Waiting(bCancel As Boolean)
Public Event Terminated(ByVal nStatus As ProcStatus, ByVal lExitCode As Long, ByVal lErrCode As Long)
Public Event Error(ByVal lErrCode As Long, ByVal sSource As String)

' Local storage for properties
Private msCommandLine As String
Private msStartFolder As String
Private mnStatus As ProcStatus
Private mlProcessID As Long
Private mlProcessHandle As Long
Private mlErrNum As Long
Private mlReturnCode As Long

' save area for current path
Private msCurrPath As String

' =========================================
' public properties - read only
' =========================================

' command line used to start the process
Public Property Get CommandLine() As String
    CommandLine = msCommandLine
End Property

' startup folder for the process
Public Property Get StartFolder() As String
    StartFolder = msStartFolder
End Property

' PID for the running process
Public Property Get ProcessID() As Long
    ProcessID = mlProcessID
End Property

' handle for the running process
Public Property Get ProcessHandle() As Long
    ProcessHandle = mlProcessHandle
End Property

' current process status
Public Property Get Status() As ProcStatus
    Status = mnStatus
End Property

' exit code from the terminated process
Public Property Get ReturnCode() As Long
    ReturnCode = mlReturnCode
End Property

' last error
Public Property Get ErrNum() As Long
    ErrNum = mlErrNum
End Property

' =========================================
' public methods
' =========================================

' start the given program and obtain the process handle
Public Function Execute(ByVal sCmdLine As String, Optional ByVal sStartFolder As String = "", Optional ByVal nWindowStyle As VbAppWinStyle = vbNormalFocus) As Boolean
  Dim lFlags As Long

  ' init
  Execute = False
  CleanStorage

  ' saves cmdline and start folder
  msCommandLine = sCmdLine
  msStartFolder = sStartFolder

  ' set drive/folder and start app
  SetFolder sStartFolder
  mlProcessID = Shell(sCmdLine, nWindowStyle)
  If mlProcessID = 0 Then
    mlErrNum = Err.LastDllError
    RaiseEvent Error(mlErrNum, "Shell")
  End If

  ' restore drive/folder and check if all ok
  SetFolder ""
  If mlProcessID = 0 Then
    Exit Function
  End If

  ' open process to obtain handle
  lFlags = PROCESS_QUERY_INFORMATION Or PROCESS_TERMINATE Or SYNCHRONIZE
  mlProcessHandle = OpenProcess(lFlags, 0, mlProcessID)
  If mlProcessHandle = INVALID_HANDLE_VALUE Then
    mlErrNum = Err.LastDllError
    RaiseEvent Error(mlErrNum, "OpenProcess")
    Exit Function
  End If

  ' all done
  mnStatus = psRunning
  RaiseEvent Started(mlProcessID, mlProcessHandle)
  Execute = True
End Function

' checks the status for the started program
Public Function CheckStatus() As ProcStatus
  Dim lWait As Long

  ' checks the handle status using a wait
  lWait = WaitForSingleObject(mlProcessHandle, 1)
  Select Case lWait
    Case WAIT_TIMEOUT
      ' process still running
      mnStatus = psRunning
      RaiseEvent Running
    Case WAIT_OBJECT_0
      ' process terminated
      mnStatus = psTerminated
      Call GetExitCodeProcess(mlProcessHandle, mlReturnCode)
      RaiseEvent Terminated(mnStatus, mlReturnCode, mlErrNum)
    Case Else
      ' error status
      mnStatus = psAborted
      mlErrNum = Err.LastDllError
      RaiseEvent Terminated(mnStatus, mlReturnCode, mlErrNum)
  End Select

  ' return current status
  CheckStatus = mnStatus
End Function

' cleans up and optionally forces termination
Public Sub Terminate(Optional ByVal bKillProcess As Boolean = False)
  Dim lRet As Long

  ' if we don't have a valid handle, exit
  If mlProcessHandle = INVALID_HANDLE_VALUE Then
    Exit Sub
  End If
  ' errand process or forced kill ?
  If (bKillProcess = True) Or (mnStatus = psAborted) Then
    lRet = TerminateProcess(mlProcessHandle, 0&)
    If lRet = 0 Then
      lRet = Err.LastDllError
      RaiseEvent Error(lRet, "TerminateProcess")
    End If
    mnStatus = psAborted
  End If
  ' close the handle, cleanup and return
  lRet = CloseHandle(mlProcessHandle)
  If lRet = 0 Then
    lRet = Err.LastDllError
    RaiseEvent Error(lRet, "CloseHandle")
  End If
  mlProcessHandle = INVALID_HANDLE_VALUE
  mlProcessID = 0
End Sub

' wait for the external process to terminate
' allows to cancel the wait and return
Public Function Wait(Optional ByVal lInterval As Long = 150) As ProcStatus
  Dim nStatus As ProcStatus
  Dim bCancel As Boolean

  ' init and start waiting
  nStatus = CheckStatus()
  While (nStatus = WAIT_TIMEOUT) And (bCancel = False)
    Call Sleep(lInterval)
    RaiseEvent Waiting(bCancel)
    If bCancel = False Then
      nStatus = CheckStatus()
    End If
  Wend

  ' return status
  Wait = nStatus
End Function

' =========================================
' private code
' =========================================

' constructor
Private Sub Class_Initialize()
  ' initialize storage
  CleanStorage
  msCurrPath = ""
End Sub

' destructor
Private Sub Class_Terminate()
  ' ensure to cleanup after ourselves
  Terminate 'True
  CleanStorage
End Sub

' set/reset current folder
Private Sub SetFolder(ByVal sNewFolder As String)
  Dim sFolder As String, sDrive As String

  ' check new folder
  sFolder = sNewFolder
  If Len(sFolder) < 1 Then
    sFolder = msCurrPath
    If Len(sFolder) < 1 Then
      Exit Sub
    End If
  End If
  ' if same as current, do nothing
  If CurDir() = sFolder Then
    Exit Sub
  End If
  ' save current folder and set new one
  msCurrPath = CurDir()
  sDrive = Mid(sFolder, 1, 2)
  ChDrive sDrive
  ChDir sFolder
End Sub

' clean local storage
Private Sub CleanStorage()
  mnStatus = psNone
  mlProcessID = 0
  mlProcessHandle = INVALID_HANDLE_VALUE
  mlErrNum = 0
  mlReturnCode = 0
  msCommandLine = ""
  msStartFolder = ""
End Sub