asked on

Controlling a shelled program (opened via CreateProcessA API)

I have pinched bits of code from various places to make this code work...
Simply, this class allows me to:
-launch an application with a specified priority
-monitor when it closes
-manually terminate it

I will soon be adding code to allow RunAs too. What I dont yet know, is how I could simply allow an initial window state such as hidden or minimized. I can hazard a guess but I thought I'd ask here. The code I confess is not my own, I mearly have crunched other peoples code together to get what I want.

Option Explicit
 
'*****************************
'* Win32 Function Stubs . . .
'*****************************
Private Declare Function GetExitCodeProcess Lib "kernel32" _
  (ByVal hProcess As Long, lpExitCode As Long) As Long
 
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function ResumeThread Lib "kernel32" (ByVal hThread As Long) As Long
 
 
'*******************
'* Win32 Types . . .
'*******************
Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessId As Long
   dwThreadId As Long
End Type
 
Private Type STARTUPINFO
   cb As Long
   lpReserved As String
   lpDesktop As String
   lpTitle As String
   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 PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szexeFile As String * 6400
End Type
 
'***********************
'* Win32 Constants . . .
'***********************
Private Const INFINITE As Long = &HFFFF
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const WINAPI_TRUE = 1
Private Const PROCESS_TERMINATE = 1
Private Const CREATE_SUSPENDED As Long = &H4
 
'************************************
'* Applications priority class . . .
'************************************
Public Enum PROCESS_PRIORITY
    ABOVE_NORMAL_PRIORITY_CLASS = &H8000
    BELOW_NORMAL_PRIORITY_CLASS = &H4000
    HIGH_PRIORITY_CLASS = &H80
    IDLE_PRIORITY_CLASS = &H40
    NORMAL_PRIORITY_CLASS = &H20
    REALTIME_PRIORITY_CLASS = &H100
End Enum
 
'******************************
'* Object State variables . . .
'******************************
Private Type PROCESS_TREE
    ProcessId As Long
    ParentProcessId As Long
End Type
 
 
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STATUS_PENDING = &H103&
 
 
Private mApplication As String
Private mArguments As String
Private mProcessInformation As PROCESS_INFORMATION
Private mSuspended As Boolean
 
Public Sub Initialise(ePriority As PROCESS_PRIORITY, Optional Suspended As Boolean = False, Optional Synchronous As Boolean = False)
 
    On Error GoTo ERR_Initialise
    
    Dim lRet As Long
    Dim lCreationFlags As Long
    Dim uStartUpInfo As STARTUPINFO
    Dim uProcessInformation As PROCESS_INFORMATION
     
    '*******************************************************
    '* Check to see if Application has been specified . . .
    '*******************************************************
    If LenB(mApplication) = 0 Then
        Err.Raise vbObjectError + 512, , "Application Not Specified"
    End If
    
    '***************************************************
    '* Check to see if Application actually exists . . .
    '***************************************************
    If LenB(Dir(mApplication)) = 0 Then
        Err.Raise vbObjectError + 512, , "Application '" & mApplication & "' Does Not Exist"
    End If
 
    '****************************************
    '* Deal with suspended applications . . .
    '****************************************
    If Suspended Then
        lCreationFlags = CREATE_SUSPENDED Or ePriority
        mSuspended = True
    Else
        lCreationFlags = ePriority
        mSuspended = False
    End If
    
    '**************************
    '* Start the Process . . .
    '**************************
    uStartUpInfo.cb = Len(uStartUpInfo)
    lRet = CreateProcessA(vbNullString, mApplication & " " & mArguments, ByVal 0&, ByVal 0&, 1&, lCreationFlags, ByVal 0&, vbNullString, uStartUpInfo, uProcessInformation)
    
    If lRet <> 0 Then
    
        If Synchronous Then
            
            '*****************************************
            '* Wait until application terminates . . .
            '*****************************************
            Call WaitForSingleObject(uProcessInformation.hProcess, INFINITE)
            
            '******************************
            '* Release stored handles . . .
            '******************************
            Call CloseHandle(mProcessInformation.hThread)
            Call CloseHandle(mProcessInformation.hProcess)
            
        Else
        
            '************************************
            '* Remember the process details . . .
            '************************************
            mProcessInformation = uProcessInformation
            
        End If
    
    Else
        Err.Raise vbObjectError + 512, , "Create Process Failed"
    End If
    
    Exit Sub
    
ERR_Initialise:
    Err.Raise Err.Number, "ProcessManager.CShell.Initialise", "Unable to Start Application '" & mApplication & " " & mArguments & _
    "' Because '" & Err.Description & "'"
End Sub
 
 
Public Sub Terminate()
 
    On Error GoTo ERR_Terminate
 
    Dim ProcessTree() As PROCESS_TREE
    
    If Not mProcessInformation.dwProcessId = 0 Then
    
        '*************************
        '* Kill off the kids . . .
        '*************************
        ProcessTree = GetProcessList()
        KillProcessTree ProcessTree, mProcessInformation.dwProcessId
        
        '***********************************
        '* Kill initial (root) process . . .
        '***********************************
        KillProcess mProcessInformation.dwProcessId
    
    End If
    
    Exit Sub
    
ERR_Terminate:
    Err.Raise Err.Number, "ProcessManager.CShell.Terminate", "Unable To Terminate Application '" & mApplication & "' Because '" & Err.Description & "'"
End Sub
 
 
Public Function IsRunning() As Boolean
  Dim exitCode As Long
  On Error Resume Next
    
  Call GetExitCodeProcess(mProcessInformation.hProcess, exitCode)
  
  If Err Or exitCode = STATUS_PENDING Then
    IsRunning = True
  Else
    IsRunning = False
  End If
 
  Err.Clear
  On Error GoTo 0
End Function
 
Public Sub Release()
 
    On Error GoTo ERR_Release
    
    '******************************************************
    '* Ensure that the thread is currently suspended . . .
    '******************************************************
    If mSuspended Then
        Call ResumeThread(mProcessInformation.hThread)
        mSuspended = False
    End If
    
    Exit Sub
    
ERR_Release:
    Err.Raise vbObjectError + 512, "ProcessManager.CShell.Release", "Unable To Release Thread Suspension Because '" & Err.Description & "'"
End Sub
 
Private Sub KillProcessTree(ProcessTree() As PROCESS_TREE, ParentProcessId As Long)
 
    Dim lCtr As Long
    
    '*********************************************
    '* Check every process for it's children . . .
    '*********************************************
    For lCtr = 0 To UBound(ProcessTree)
        If ProcessTree(lCtr).ParentProcessId = ParentProcessId Then
            KillProcessTree ProcessTree, ProcessTree(lCtr).ProcessId
            KillProcess ProcessTree(lCtr).ProcessId
        End If
    Next
        
End Sub
 
Private Function GetProcessList() As PROCESS_TREE()
 
    On Error GoTo ERR_GetProcessTree
 
    Dim hSnapShot As Long
    Dim hProcess As Long
    Dim uProcessEntry As PROCESSENTRY32
    Dim lSuccess As Long
    Dim ProcessTree() As PROCESS_TREE
    Dim lCtr As Long
    
    '************************************************************
    '* Get a snapshot of all of the processes in the system . . .
    '************************************************************
    hSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
    
    '***********************************************
    '* If we don't have a snapshot then finish . . .
    '***********************************************
    If hSnapShot = INVALID_HANDLE_VALUE Then
        Err.Raise vbObjectError + 512, , "Unable To Get Process Snapshot"
    Else
    
        '*********************************
        '* Get first process in list . . .
        '*********************************
        uProcessEntry.dwSize = Len(uProcessEntry)
        lSuccess = ProcessFirst(hSnapShot, uProcessEntry)
        
        If lSuccess = WINAPI_TRUE Then
        
            lCtr = 0
            
            '**********************************
            '* Loop through all processes . . .
            '**********************************
            Do Until lSuccess <> WINAPI_TRUE
            
                ReDim Preserve ProcessTree(lCtr)
                With ProcessTree(lCtr)
                    .ParentProcessId = uProcessEntry.th32ParentProcessID
                    .ProcessId = uProcessEntry.th32ProcessID
                End With
                
                lCtr = lCtr + 1
                lSuccess = ProcessNext(hSnapShot, uProcessEntry)
                
            Loop
        
        Else
            Err.Raise vbObjectError + 512, , "Unable To Get First Process In Snapshot"
        End If
    
    End If
    
    '********************************
    '* Release handle resources . . .
    '********************************
    CloseHandle (hSnapShot)
    
    GetProcessList = ProcessTree
    Exit Function
    
ERR_GetProcessTree:
 
    CloseHandle (hSnapShot)
    Err.Raise Err.Number, Err.Source, Err.Description
    
End Function
 
Private Sub KillProcess(ProcessId As Long)
 
    On Error GoTo ERR_KillProcess
 
    Dim hProcess As Long
    Dim lExitCode As Long
 
    '*************************************************
    '* Kill the process, and release the handle . . .
    '*************************************************
    hProcess = OpenProcess(PROCESS_TERMINATE, False, ProcessId)
    Call TerminateProcess(hProcess, lExitCode)
    Call CloseHandle(hProcess)
    
    Exit Sub
    
ERR_KillProcess:
    Call CloseHandle(hProcess)
End Sub
 
Property Let Application(sApplication As String)
    mApplication = sApplication
End Property
 
 
Property Get Application() As String
    Application = mApplication
End Property
 
 
Property Let Arguments(sArguments As String)
    mArguments = sArguments
End Property
 
 
Property Get Arguments() As String
    Arguments = mArguments
End Property

Open in new window

ASKER CERTIFIED SOLUTION

tasky

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

dentab

ASKER

That looks great, I'll give it a try.

tasky

You can also turn the ShowWindow flags into an enum and modify the procedure's declaration as follows: (note---if you use the enum route, remove the SW const declarations)

Public Enum ShowWindowFlag
SW_SHOWDEFAULT = 10
SW_SHOWMAXIMIZED = 3
SW_SHOWMINIMIZED = 2
SW_SHOWMINNOACTIVE = 7
SW_SHOWNOACTIVATE = 4
SW_SHOWNORMAL = 1
End Enum
 
Public Sub Initialise(ePriority As PROCESS_PRIORITY, Optional Suspended As Boolean = False, Optional Synchronous As Boolean = False, Optional SWState As ShowWindowFlag = SW_SHOWNORMAL)

Open in new window

dentab

ASKER

Have I done something wrong?

It seems to have no effect

Option Explicit
 
'*****************************
'* Win32 Function Stubs . . .
'*****************************
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function ResumeThread Lib "kernel32" (ByVal hThread As Long) As Long
 
 
'*******************
'* Win32 Types . . .
'*******************
Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessId As Long
   dwThreadId As Long
End Type
 
Private Type STARTUPINFO
   cb As Long
   lpReserved As String
   lpDesktop As String
   lpTitle As String
   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 PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szexeFile As String * 6400
End Type
 
'***********************
'* Win32 Constants . . .
'***********************
Private Const INFINITE As Long = &HFFFF
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const WINAPI_TRUE = 1
Private Const PROCESS_TERMINATE = 1
Private Const CREATE_SUSPENDED As Long = &H4
 
'************************************
'* Applications priority class . . .
'************************************
Public Enum PROCESS_PRIORITY
    ABOVE_NORMAL_PRIORITY_CLASS = &H8000
    BELOW_NORMAL_PRIORITY_CLASS = &H4000
    HIGH_PRIORITY_CLASS = &H80
    IDLE_PRIORITY_CLASS = &H40
    NORMAL_PRIORITY_CLASS = &H20
    REALTIME_PRIORITY_CLASS = &H100
End Enum
 
'************************************
'* Initial Windowstate
'************************************
Public Enum APPLICATION_WINDOWSTATE
  SW_SHOWDEFAULT = 10
  SW_SHOWMAXIMIZED = 3
  SW_SHOWMINIMIZED = 2
  SW_SHOWMINNOACTIVE = 7
  SW_SHOWNOACTIVATE = 4
  SW_SHOWNORMAL = 1
End Enum
 
'******************************
'* Object State variables . . .
'******************************
Private Type PROCESS_TREE
    ProcessId As Long
    ParentProcessId As Long
End Type
 
 
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STATUS_PENDING = &H103&
 
Private mApplication As String
Private mArguments As String
Private mProcessInformation As PROCESS_INFORMATION
Private mSuspended As Boolean
 
Public Sub Initialise(ePriority As PROCESS_PRIORITY, Optional Suspended As Boolean = False, Optional WindowState As APPLICATION_WINDOWSTATE = APPLICATION_WINDOWSTATE.SW_SHOWDEFAULT, Optional Synchronous As Boolean = False)
 
    On Error GoTo ERR_Initialise
    
    Dim lRet As Long
    Dim lCreationFlags As Long
    Dim uStartUpInfo As STARTUPINFO
    Dim uProcessInformation As PROCESS_INFORMATION
     
    '*******************************************************
    '* Check to see if Application has been specified . . .
    '*******************************************************
    If LenB(mApplication) = 0 Then
        Err.Raise vbObjectError + 512, , "Application Not Specified"
    End If
    
    '***************************************************
    '* Check to see if Application actually exists . . .
    '***************************************************
    If LenB(Dir(mApplication)) = 0 Then
        Err.Raise vbObjectError + 512, , "Application '" & mApplication & "' Does Not Exist"
    End If
    
 
    '****************************************
    '* Deal with suspended applications . . .
    '****************************************
    If Suspended Then
        lCreationFlags = CREATE_SUSPENDED Or ePriority
        mSuspended = True
    Else
        lCreationFlags = ePriority
        mSuspended = False
    End If
    
    '**************************
    '* Start the Process . . .
    '**************************
    uStartUpInfo.wShowWindow = CInt(WindowState)
    uStartUpInfo.cb = Len(uStartUpInfo)
    lRet = CreateProcessA(vbNullString, mApplication & " " & mArguments, ByVal 0&, ByVal 0&, 1&, lCreationFlags, ByVal 0&, vbNullString, uStartUpInfo, uProcessInformation)
    
    If lRet <> 0 Then
    
        If Synchronous Then
            
            '*****************************************
            '* Wait until application terminates . . .
            '*****************************************
            Call WaitForSingleObject(uProcessInformation.hProcess, INFINITE)
            
            '******************************
            '* Release stored handles . . .
            '******************************
            Call CloseHandle(mProcessInformation.hThread)
            Call CloseHandle(mProcessInformation.hProcess)
            
        Else
        
            '************************************
            '* Remember the process details . . .
            '************************************
            mProcessInformation = uProcessInformation
            
        End If
    
    Else
        Err.Raise vbObjectError + 512, , "Create Process Failed"
    End If
    
    Exit Sub
    
ERR_Initialise:
    Err.Raise Err.Number, "ProcessManager.CShell.Initialise", "Unable to Start Application '" & mApplication & " " & mArguments & _
    "' Because '" & Err.Description & "'"
End Sub
 
 
Public Sub Terminate()
 
    On Error GoTo ERR_Terminate
 
    Dim ProcessTree() As PROCESS_TREE
    
    If Not mProcessInformation.dwProcessId = 0 Then
    
        '*************************
        '* Kill off the kids . . .
        '*************************
        ProcessTree = GetProcessList()
        KillProcessTree ProcessTree, mProcessInformation.dwProcessId
        
        '***********************************
        '* Kill initial (root) process . . .
        '***********************************
        KillProcess mProcessInformation.dwProcessId
    
    End If
    
    Exit Sub
    
ERR_Terminate:
    Err.Raise Err.Number, "ProcessManager.CShell.Terminate", "Unable To Terminate Application '" & mApplication & "' Because '" & Err.Description & "'"
End Sub
 
 
Public Function IsRunning() As Boolean
  Dim exitCode As Long
  On Error Resume Next
    
  Call GetExitCodeProcess(mProcessInformation.hProcess, exitCode)
  
  If Err Or exitCode = STATUS_PENDING Then
    IsRunning = True
  Else
    IsRunning = False
  End If
 
  Err.Clear
  On Error GoTo 0
End Function
 
Public Sub Release()
 
    On Error GoTo ERR_Release
    
    '******************************************************
    '* Ensure that the thread is currently suspended . . .
    '******************************************************
    If mSuspended Then
        Call ResumeThread(mProcessInformation.hThread)
        mSuspended = False
    End If
    
    Exit Sub
    
ERR_Release:
    Err.Raise vbObjectError + 512, "ProcessManager.CShell.Release", "Unable To Release Thread Suspension Because '" & Err.Description & "'"
End Sub
 
Private Sub KillProcessTree(ProcessTree() As PROCESS_TREE, ParentProcessId As Long)
 
    Dim lCtr As Long
    
    '*********************************************
    '* Check every process for it's children . . .
    '*********************************************
    For lCtr = 0 To UBound(ProcessTree)
        If ProcessTree(lCtr).ParentProcessId = ParentProcessId Then
            KillProcessTree ProcessTree, ProcessTree(lCtr).ProcessId
            KillProcess ProcessTree(lCtr).ProcessId
        End If
    Next
        
End Sub
 
Private Function GetProcessList() As PROCESS_TREE()
 
    On Error GoTo ERR_GetProcessTree
 
    Dim hSnapShot As Long
    Dim hProcess As Long
    Dim uProcessEntry As PROCESSENTRY32
    Dim lSuccess As Long
    Dim ProcessTree() As PROCESS_TREE
    Dim lCtr As Long
    
    '************************************************************
    '* Get a snapshot of all of the processes in the system . . .
    '************************************************************
    hSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
    
    '***********************************************
    '* If we don't have a snapshot then finish . . .
    '***********************************************
    If hSnapShot = INVALID_HANDLE_VALUE Then
        Err.Raise vbObjectError + 512, , "Unable To Get Process Snapshot"
    Else
    
        '*********************************
        '* Get first process in list . . .
        '*********************************
        uProcessEntry.dwSize = Len(uProcessEntry)
        lSuccess = ProcessFirst(hSnapShot, uProcessEntry)
        
        If lSuccess = WINAPI_TRUE Then
        
            lCtr = 0
            
            '**********************************
            '* Loop through all processes . . .
            '**********************************
            Do Until lSuccess <> WINAPI_TRUE
            
                ReDim Preserve ProcessTree(lCtr)
                With ProcessTree(lCtr)
                    .ParentProcessId = uProcessEntry.th32ParentProcessID
                    .ProcessId = uProcessEntry.th32ProcessID
                End With
                
                lCtr = lCtr + 1
                lSuccess = ProcessNext(hSnapShot, uProcessEntry)
                
            Loop
        
        Else
            Err.Raise vbObjectError + 512, , "Unable To Get First Process In Snapshot"
        End If
    
    End If
    
    '********************************
    '* Release handle resources . . .
    '********************************
    CloseHandle (hSnapShot)
    
    GetProcessList = ProcessTree
    Exit Function
    
ERR_GetProcessTree:
 
    CloseHandle (hSnapShot)
    Err.Raise Err.Number, Err.Source, Err.Description
    
End Function
 
Private Sub KillProcess(ProcessId As Long)
 
    On Error GoTo ERR_KillProcess
 
    Dim hProcess As Long
    Dim lExitCode As Long
 
    '*************************************************
    '* Kill the process, and release the handle . . .
    '*************************************************
    hProcess = OpenProcess(PROCESS_TERMINATE, False, ProcessId)
    Call TerminateProcess(hProcess, lExitCode)
    Call CloseHandle(hProcess)
    
    Exit Sub
    
ERR_KillProcess:
    Call CloseHandle(hProcess)
End Sub
 
Property Let Application(sApplication As String)
    mApplication = sApplication
End Property
 
 
Property Get Application() As String
    Application = mApplication
End Property
 
 
Property Let Arguments(sArguments As String)
    mArguments = sArguments
End Property
 
 
Property Get Arguments() As String
    Arguments = mArguments
End Property

Open in new window

dentab

ASKER

Sorry, I saw you last post appear - only after my code submission.

I had already tried enumerating and since your last post I have removed the SW_ prefix
Still no joy though :(

Public Enum APPLICATION_WINDOWSTATE
  SHOWDEFAULT = 10
  SHOWMAXIMIZED = 3
  SHOWMINIMIZED = 2
  SHOWMINNOACTIVE = 7
  SHOWNOACTIVATE = 4
  SHOWNORMAL = 1
End Enum

Open in new window

dentab

ASKER

aha, something about dwFlags - I need to find the value for
STARTF_USESHOWWINDOW

http://msdn2.microsoft.com/en-us/library/ms686331(VS.85).aspx

dentab

ASKER

lol, its value is 1...

Thanks for all your help

This works:

Option Explicit
 
'*****************************
'* Win32 Function Stubs . . .
'*****************************
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function ResumeThread Lib "kernel32" (ByVal hThread As Long) As Long
 
 
'*******************
'* Win32 Types . . .
'*******************
Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessId As Long
   dwThreadId As Long
End Type
 
Private Type STARTUPINFO
   cb As Long
   lpReserved As String
   lpDesktop As String
   lpTitle As String
   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 PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szexeFile As String * 6400
End Type
 
'***********************
'* Win32 Constants . . .
'***********************
Private Const INFINITE As Long = &HFFFF
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const WINAPI_TRUE = 1
Private Const PROCESS_TERMINATE = 1
Private Const CREATE_SUSPENDED As Long = &H4
 
'************************************
'* Applications priority class . . .
'************************************
Public Enum PROCESS_PRIORITY
    ABOVE_NORMAL_PRIORITY_CLASS = &H8000
    BELOW_NORMAL_PRIORITY_CLASS = &H4000
    HIGH_PRIORITY_CLASS = &H80
    IDLE_PRIORITY_CLASS = &H40
    NORMAL_PRIORITY_CLASS = &H20
    REALTIME_PRIORITY_CLASS = &H100
End Enum
 
'************************************
'* Initial Windowstate
'************************************
Public Enum APPLICATION_WINDOWSTATE
  SHOWDEFAULT = 10
  SHOWMAXIMIZED = 3
  SHOWMINIMIZED = 2
  SHOWMINNOACTIVE = 7
  SHOWNOACTIVATE = 4
  SHOWNORMAL = 1
End Enum
 
 
Private Const STARTF_USESHOWWINDOW = &H1 '0x01 If this value is not specified, the wShowWindow member is ignored.
Private Const STARTF_USESIZE = &H2 '0x02 If this value is not specified, the dwXSize and dwYSize members are ignored.
Private Const STARTF_USEPOSITION = &H4 '0x04 If this value is not specified, the dwX and dwY members are ignored.
Private Const STARTF_USECOUNTCHARS = &H8 '0x08 If this value is not specified, the dwXCountChars and dwYCountChars members are ignored.
Private Const STARTF_USEFILLATTRIBUTE = &H10 '0x10 If this value is not specified, the dwFillAttribute member is ignored.
Private Const STARTF_RUNFULLSCREEN = &H20 '0x20 Indicates that the process should be run in full-screen mode, rather than in windowed mode.
Private Const STARTF_FORCEONFEEDBACK = &H40 '0x40 Indicates that the cursor is in feedback mode for two seconds after CreateProcess is called.
Private Const STARTF_FORCEOFFFEEDBACK = &H80 '0x80 Indicates that the feedback cursor is forced off while the process is starting. The normal cursor is displayed.
Private Const STARTF_USESTDHANDLES = &H100 '0x100 Sets the standard input, standard output, and standard error handles for the process to the handles specified in the hStdInput, hStdOutput, and hStdError members of the STARTUPINFO structure.
 
 
'******************************
'* Object State variables . . .
'******************************
Private Type PROCESS_TREE
    ProcessId As Long
    ParentProcessId As Long
End Type
 
 
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STATUS_PENDING = &H103&
 
Private mApplication As String
Private mArguments As String
Private mProcessInformation As PROCESS_INFORMATION
Private mSuspended As Boolean
 
Public Sub Initialise(ePriority As PROCESS_PRIORITY, Optional Suspended As Boolean = False, Optional WindowState As APPLICATION_WINDOWSTATE = APPLICATION_WINDOWSTATE.SHOWDEFAULT, Optional Synchronous As Boolean = False)
 
    On Error GoTo ERR_Initialise
    
    Dim lRet As Long
    Dim lCreationFlags As Long
    Dim uStartUpInfo As STARTUPINFO
    Dim uProcessInformation As PROCESS_INFORMATION
     
    '*******************************************************
    '* Check to see if Application has been specified . . .
    '*******************************************************
    If LenB(mApplication) = 0 Then
        Err.Raise vbObjectError + 512, , "Application Not Specified"
    End If
    
    '***************************************************
    '* Check to see if Application actually exists . . .
    '***************************************************
    If LenB(Dir(mApplication)) = 0 Then
        Err.Raise vbObjectError + 512, , "Application '" & mApplication & "' Does Not Exist"
    End If
    
 
    '****************************************
    '* Deal with suspended applications . . .
    '****************************************
    If Suspended Then
        lCreationFlags = CREATE_SUSPENDED Or ePriority
        mSuspended = True
    Else
        lCreationFlags = ePriority
        mSuspended = False
    End If
    
    '**************************
    '* Start the Process . . .
    '**************************
    uStartUpInfo.dwFlags = STARTF_USESHOWWINDOW
    uStartUpInfo.wShowWindow = CInt(WindowState)
    uStartUpInfo.cb = Len(uStartUpInfo)
    lRet = CreateProcessA(vbNullString, mApplication & " " & mArguments, ByVal 0&, ByVal 0&, 1&, lCreationFlags, ByVal 0&, vbNullString, uStartUpInfo, uProcessInformation)
    
    If lRet <> 0 Then
    
        If Synchronous Then
            
            '*****************************************
            '* Wait until application terminates . . .
            '*****************************************
            Call WaitForSingleObject(uProcessInformation.hProcess, INFINITE)
            
            '******************************
            '* Release stored handles . . .
            '******************************
            Call CloseHandle(mProcessInformation.hThread)
            Call CloseHandle(mProcessInformation.hProcess)
            
        Else
        
            '************************************
            '* Remember the process details . . .
            '************************************
            mProcessInformation = uProcessInformation
            
        End If
    
    Else
        Err.Raise vbObjectError + 512, , "Create Process Failed"
    End If
    
    Exit Sub
    
ERR_Initialise:
    Err.Raise Err.Number, "ProcessManager.CShell.Initialise", "Unable to Start Application '" & mApplication & " " & mArguments & _
    "' Because '" & Err.Description & "'"
End Sub
 
 
Public Sub Terminate()
 
    On Error GoTo ERR_Terminate
 
    Dim ProcessTree() As PROCESS_TREE
    
    If Not mProcessInformation.dwProcessId = 0 Then
    
        '*************************
        '* Kill off the kids . . .
        '*************************
        ProcessTree = GetProcessList()
        KillProcessTree ProcessTree, mProcessInformation.dwProcessId
        
        '***********************************
        '* Kill initial (root) process . . .
        '***********************************
        KillProcess mProcessInformation.dwProcessId
    
    End If
    
    Exit Sub
    
ERR_Terminate:
    Err.Raise Err.Number, "ProcessManager.CShell.Terminate", "Unable To Terminate Application '" & mApplication & "' Because '" & Err.Description & "'"
End Sub
 
 
Public Function IsRunning() As Boolean
  Dim exitCode As Long
  On Error Resume Next
    
  Call GetExitCodeProcess(mProcessInformation.hProcess, exitCode)
  
  If Err Or exitCode = STATUS_PENDING Then
    IsRunning = True
  Else
    IsRunning = False
  End If
 
  Err.Clear
  On Error GoTo 0
End Function
 
Public Sub Release()
 
    On Error GoTo ERR_Release
    
    '******************************************************
    '* Ensure that the thread is currently suspended . . .
    '******************************************************
    If mSuspended Then
        Call ResumeThread(mProcessInformation.hThread)
        mSuspended = False
    End If
    
    Exit Sub
    
ERR_Release:
    Err.Raise vbObjectError + 512, "ProcessManager.CShell.Release", "Unable To Release Thread Suspension Because '" & Err.Description & "'"
End Sub
 
Private Sub KillProcessTree(ProcessTree() As PROCESS_TREE, ParentProcessId As Long)
 
    Dim lCtr As Long
    
    '*********************************************
    '* Check every process for it's children . . .
    '*********************************************
    For lCtr = 0 To UBound(ProcessTree)
        If ProcessTree(lCtr).ParentProcessId = ParentProcessId Then
            KillProcessTree ProcessTree, ProcessTree(lCtr).ProcessId
            KillProcess ProcessTree(lCtr).ProcessId
        End If
    Next
        
End Sub
 
Private Function GetProcessList() As PROCESS_TREE()
 
    On Error GoTo ERR_GetProcessTree
 
    Dim hSnapShot As Long
    Dim hProcess As Long
    Dim uProcessEntry As PROCESSENTRY32
    Dim lSuccess As Long
    Dim ProcessTree() As PROCESS_TREE
    Dim lCtr As Long
    
    '************************************************************
    '* Get a snapshot of all of the processes in the system . . .
    '************************************************************
    hSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
    
    '***********************************************
    '* If we don't have a snapshot then finish . . .
    '***********************************************
    If hSnapShot = INVALID_HANDLE_VALUE Then
        Err.Raise vbObjectError + 512, , "Unable To Get Process Snapshot"
    Else
    
        '*********************************
        '* Get first process in list . . .
        '*********************************
        uProcessEntry.dwSize = Len(uProcessEntry)
        lSuccess = ProcessFirst(hSnapShot, uProcessEntry)
        
        If lSuccess = WINAPI_TRUE Then
        
            lCtr = 0
            
            '**********************************
            '* Loop through all processes . . .
            '**********************************
            Do Until lSuccess <> WINAPI_TRUE
            
                ReDim Preserve ProcessTree(lCtr)
                With ProcessTree(lCtr)
                    .ParentProcessId = uProcessEntry.th32ParentProcessID
                    .ProcessId = uProcessEntry.th32ProcessID
                End With
                
                lCtr = lCtr + 1
                lSuccess = ProcessNext(hSnapShot, uProcessEntry)
                
            Loop
        
        Else
            Err.Raise vbObjectError + 512, , "Unable To Get First Process In Snapshot"
        End If
    
    End If
    
    '********************************
    '* Release handle resources . . .
    '********************************
    CloseHandle (hSnapShot)
    
    GetProcessList = ProcessTree
    Exit Function
    
ERR_GetProcessTree:
 
    CloseHandle (hSnapShot)
    Err.Raise Err.Number, Err.Source, Err.Description
    
End Function
 
Private Sub KillProcess(ProcessId As Long)
 
    On Error GoTo ERR_KillProcess
 
    Dim hProcess As Long
    Dim lExitCode As Long
 
    '*************************************************
    '* Kill the process, and release the handle . . .
    '*************************************************
    hProcess = OpenProcess(PROCESS_TERMINATE, False, ProcessId)
    Call TerminateProcess(hProcess, lExitCode)
    Call CloseHandle(hProcess)
    
    Exit Sub
    
ERR_KillProcess:
    Call CloseHandle(hProcess)
End Sub
 
Property Let Application(sApplication As String)
    mApplication = sApplication
End Property
 
 
Property Get Application() As String
    Application = mApplication
End Property
 
 
Property Let Arguments(sArguments As String)
    mArguments = sArguments
End Property
 
 
Property Get Arguments() As String
    Arguments = mArguments
End Property

Open in new window

dentab

ASKER

The flags needed to be updated to make it take note of the states, but you put me on the right path - thanks.

http://msdn2.microsoft.com/en-us/library/ms686331(VS.85).aspx
http://catch22.net/tuts/undoc01.asp

dentab

ASKER

For anyone who found this useful, here is a better enumeration thanks to
http://www.codeprof.com/dev-archive/12/10-32-123940.shtm

Public Enum APPLICATION_WINDOWSTATE
  SW_SHOWDEFAULT = 10    ' Sets the show state based on the SW_ value specified in the STARTUPINFO
  SW_SHOWMAXIMIZED = 3   ' Activates the window and displays it as a maximized window.
  SW_SHOWMINIMIZED = 2   ' Activates the window and displays it as a minimized window.
  
' Windows 2000/XP: Minimizes a window, even if the thread that owns
' the window is not responding. This flag should only be used when
' minimizing windows from a different thread.
  SW_FORCEMINIMIZE = 11
 
 
' Hides the window and activates another window.
  SW_HIDE = 0
 
' Maximizes the specified window.
  SW_MAXIMIZE = 3
 
' Minimizes the specified window and activates the next top-level window in the Z order.
  SW_MINIMIZE = 6
 
' Activates and displays the window. If the window is minimized or maximized,
' the system restores it to its original size and position.
' An application should specify this flag when restoring a minimized window.
  SW_RESTORE = 9
 
' Activates the window and displays it in its current size and position.
  SW_SHOW = 5
 
 
' Displays the window as a minimized window. This value is
' similar to SW_SHOWMINIMIZED, except the window is not activated.
  SW_SHOWMINNOACTIVE = 7
 
' Displays the window in its current size and position. This value
' is similar to SW_SHOW, except the window is not activated.
  SW_SHOWNA = 8
 
' Displays a window in its most recent size and position.
' This value is similar to SW_SHOWNORMAL, except the window is not actived.
  SW_SHOWNOACTIVATE = 4
 
' Activates and displays a window. If the window is minimized or maximized,
' the system restores it to its original size and position. An application should
' specify this flag when displaying the window for the first time.
  SW_SHOWNORMAL = 1  
End Enum

Open in new window