vbAccelerator - Contents of code file: SHELWAIT.BAS

Attribute VB_Name = "ShellWait"
Option Explicit

Private Declare Sub Sleep Lib "KERNEL32" (ByVal dwMilliseconds As Long)
Private Declare Function GetExitCodeProcess Lib "KERNEL32" (ByVal hProcess As
 Long, lpExitCode As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function OpenProcess Lib "KERNEL32" (ByVal dwDesiredAccess As
 Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Const STILL_ACTIVE = &H103
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As
 Long

Public Function ShellAndWaitForTermination( _
        sShell As String, _
        Optional ByVal eWindowStyle As VBA.VbAppWinStyle = vbNormalFocus, _
        Optional ByRef sError As String, _
        Optional ByVal lTimeOut As Long = 2000000000 _
    ) As Boolean
Dim hProcess As Long
Dim lR As Long
Dim lTimeStart As Long
Dim bSuccess As Boolean
    
On Error GoTo ShellAndWaitForTerminationError
    
    ' This is v2 which is somewhat more reliable:
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(sShell,
     eWindowStyle))
    If (hProcess = 0) Then
        sError = "This program could not determine whether the process started.
          Please watch the program and check it completes."
        ' Only fail if there is an error - this can happen when the program
         completes too quickly.
    Else
        bSuccess = True
        lTimeStart = timeGetTime()
        Do
            ' Get the status of the process
            GetExitCodeProcess hProcess, lR
            ' Sleep during wait to ensure the other process gets
            ' processor slice:
            DoEvents: Sleep 100
            If (timeGetTime() - lTimeStart > lTimeOut) Then
                ' Too long!
                sError = "The process has timed out."
                lR = 0
                bSuccess = False
            End If
        Loop While lR = STILL_ACTIVE
    End If
    ShellAndWaitForTermination = bSuccess
        
    Exit Function

ShellAndWaitForTerminationError:
    sError = Err.Description
    Exit Function
End Function