CShellProc.cls

Option Explicit

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

' process flags
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const SYNCHRONIZE = &H100000
Private Const PROCESS_QUERY_INFORMATION As Long = &H400
Private Const PROCESS_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF&)

' invalid handle
Private Const INVALID_HANDLE = &H0&

' wait constants
Private Const WAIT_OBJECT_0 = &H0&          ' wait terminated
Private Const WAIT_TIMEOUT = &H102&         ' wait timed out
Private Const WAIT_IO_COMPLETION = &HC0&    ' wait I/O completion port
Private Const WAIT_ABANDONED = &H80&        ' wait failed, process aborted
Private Const WAIT_FAILED = &HFFFFFFFF      ' wait failed, cannot wait handle

' timeout for the Wait call
Private Const WAIT_TIME = 11                ' use a prime number here ;-)

' internal storage
Private mvAppID         As Variant          ' application ID
Private msCmdLine       As String           ' command line
Private mdwPID          As Long             ' process ID
Private mhProcHandle    As Long             ' process handle
Private mlDLLerr        As Long             ' DLL error (GetLastError)
Private mlExitCode      As Long             ' application exit code


' instance
Private Sub Class_Initialize()
  mdwPID = INVALID_HANDLE
  mhProcHandle = INVALID_HANDLE
  mlDLLerr = -1
  mlExitCode = -1
  mvAppID = -1
  msCmdLine = sCmdLine
End Sub

' destroy
Private Sub Class_Terminate()
  If mhProcHandle <> INVALID_HANDLE Then
    EndApp
  End If
End Sub

' application ID
Public Property Get AppID() As Variant
  AppID = mvAppID
End Property

' command line
Public Property Get CmdLine() As String
  CmdLine = msCmdLine
End Property

' error number (if any)
Public Property Get ErrNum() As Long
  ErrNum = mlDLLerr
End Property

' application exit code
Public Property Get ExitCode() As Long
  ExitCode = mlExitCode
End Property

' starts the given app, returns true if started
Public Function StartApp(ByVal vAppID As Variant, ByVal sCmdLine As String, Optional ByVal vStyle As VbAppWinStyle = vbNormalFocus) As Boolean
  ' catch shell errors
  On Local Error Resume Next

  ' initialize
  StartApp = False
  mdwPID = INVALID_HANDLE
  mhProcHandle = INVALID_HANDLE
  mlDLLerr = -1
  mlExitCode = -1
  bCancel = False

  ' store infos
  mvAppID = vAppID
  msCmdLine = sCmdLine


  ' shell the program and get the PID
  Err.Clear
  mdwPID = Shell(sCmdLine, vStyle)
  If Err.Number <> 0 Then
    ' shell error, set values and return
    mlDLLerr = Err.Number
    mlExitCode = -1
    Exit Function
  End If

  If mdwPID <> INVALID_HANDLE Then
    ' obtain a process handle from PIC
    mhProcHandle = OpenProcess(PROCESS_ALL_ACCESS, 0, mdwPID)
    mlDLLerr = Err.LastDllError
    If mhProcHandle = INVALID_HANDLE Then
      Exit Function
    End If
  End If

  StartApp = True
End Function

' check if the started app is still running
Public Function IsRunning() As Boolean
  Dim lWait As Long, lRet As Long
  Dim bRun As Boolean

  ' init
  bRun = False
  IsRunning = bRun

  ' check if we have a handle
  If mhProcHandle = INVALID_HANDLE Then
    ' not started !
    Exit Function
  End If

  ' run a quick check to see if the process is running
  lWait = WaitForSingleObject(mhProcHandle, WAIT_TIME)
  mlDLLerr = Err.LastDllError

  ' check the result
  Select Case lWait
    Case WAIT_OBJECT_0
      ' process terminated
      lRet = GetExitCodeProcess(mhProcHandle, mlExitCode)
      If lRet = 0 Then
        mlExitCode = -1
        mlDLLerr = Err.LastDllError
      End If
      bRun = False
    Case WAIT_TIMEOUT
      ' timed out, still running
      bRun = True
    Case Else
      ' error
      If mlDLLerr = 0 Then
        mlDLLerr = lWait
      End If
      mlExitCode = -1
      bRun = False
  End Select

  If bRun = False Then
    ' not running, cleanup
    EndApp
  End If

  ' true if running
  IsRunning = bRun
End Function

' started process terminated (or must be killed)
Public Sub EndApp(ByVal bKill As Boolean)
  ' do we have a process handle ?
  If mhProcHandle = INVALID_HANDLE Then
    Exit Sub
  End If

  ' are we asked to KILL the process ?
  If bKill Then
    Call TerminateProcess(mhProcHandle, -1&)
    If Err.LastDllError <> 0 Then
      mlDLLerr = Err.LastDllError
    End If
  End If

  ' cleanup
  Call CloseHandle(mhProcHandle)
  mhProcHandle = INVALID_HANDLE
  mdwPID = INVALID_HANDLE
End Function