VB6 Shell out and wait

http://stackoverflow.com/questions/5685972/how-to-wait-for-a-shell-process-to-finish-before-executing-further-code-in-vb6

ShellExecuteEx example
http://www.jasinskionline.com/windowsapi/ref/s/shellexecuteex.html


Option Explicit


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

' WaitForSingleObject
Private Const INFINITE = &HFFFF
Private Const WAIT_TIMEOUT = &H102

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long


Public Sub Pause(seconds As Integer)
    Dim milliseconds As Long
    
    If seconds > 0 Then
        milliseconds = seconds * 1000
        
        Call Sleep(milliseconds)
    End If
End Sub

'
'   Description:
'   The function will shell out and wait.
'
'   Parameters:
'   a_Command_Line      - The text for executing the shell out command.
'   a_Tmeout_second     - The timeout in seconds until stop waiting.  If the value is zero or negative value, the function will wait until the shell out command finished.
'   a_WindowStyle       - The setting for the window style.  The default is minimized without focus.
'   a_ForceTerminate    - The default is false.
'
'   Return:
'   This function return exit code from the shell out program.  In case of error, it return -1.
'
'   Exceptions
'   This function expects the caller will handle exceptions.
'
'  Remark:
'  This function is based on the following example.
'  http://stackoverflow.com/questions/292098/vb-6-how-can-i-execute-a-bat-file-but-wait-until-its-done-running-before-movin
'
'
Public Function ShellandWait(a_Command_Line As String, Optional a_Tmeout_second As Long = 0, Optional a_WindowStyle As VbAppWinStyle = vbMinimizedNoFocus, Optional a_ForceTerminate As Boolean = False) As Long
    Const ERROR_SOURCE = "ShellandWait"
    
    Dim pid As Long
    Dim hnd As Long
    Dim timeout_millisecond As Long
    Dim return_value As Long
    Dim exit_code As Long
    
    ' set the default exit code to fail
    exit_code = -1
    
    pid = Shell(a_Command_Line, a_WindowStyle)
    If pid <> 0 Then
    
        ' open handle for wait
        hnd = OpenProcess(SYNCHRONIZE Or PROCESS_QUERY_INFORMATION, 0, pid)
        If hnd <> 0 Then
        
            If a_Tmeout_second > 0 Then
                timeout_millisecond = a_Tmeout_second * 1000
            Else
                timeout_millisecond = INFINITE
            End If
            
            return_value = WaitForSingleObject(hnd, timeout_millisecond)
            
            If return_value = WAIT_TIMEOUT And a_ForceTerminate Then
                ' reopen the handle for termination
                Call CloseHandle(hnd)
                hnd = OpenProcess(PROCESS_TERMINATE, 0, pid)
                If hnd <> 0 Then
                
                    return_value = TerminateProcess(hnd, exit_code)
                
                    Call CloseHandle(hnd)
                
                    Err.Raise &H8004AA00, ERROR_SOURCE, "The process(" & CStr(pid) & ") '" & a_Command_Line & "' is terminated because of time out"
                Else
                    Err.Raise &H8004AA01, ERROR_SOURCE, "Failed to open child process"
                End If
            Else
                return_value = GetExitCodeProcess(hnd, exit_code)

                Call CloseHandle(hnd)
                            
                If return_value = 0 Then
                    Err.Raise &H8004AA02, ERROR_SOURCE, "Failed to retrieve exit code, error " & CStr(Err.LastDllError)
                End If
            End If
        Else
            Err.Raise &H8004AA03, ERROR_SOURCE, "Failed to open child process"
        End If
    Else
        Err.Raise &H8004AA04, ERROR_SOURCE, "Failed to Shell child process"
    End If
    
    ShellandWait = exit_code
End Function

Advertisements

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s