'終了待ちをするShell関数

Option Explicit

Private Type SHELLEXECUTEINFO
    cbSize        As Long
    fMask         As Long
    hwnd          As Long
    lpVerb        As String
    lpFile        As String
    lpParameters  As String
    lpDirectory   As String
    nShow         As Long
    hInstApp      As Long
    lpIDList      As Long
    lpClass       As String
    hkeyClass     As Long
    dwHotKey      As Long
    hIcon         As Long
    hProcess      As Long
End Type

Private Const SEE_MASK_FLAG_NO_UI = &H400
Private Const SEE_MASK_NOCLOSEPROCESS = &H40

Private Declare Function ShellExecuteEx Lib "shell32.dll" ( _
    ByRef lpExecInfo As SHELLEXECUTEINFO) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long


Private Const PROCESS_QUERY_INFORMATION = &H400&
Private Const STILL_ACTIVE = &H103&

Private Declare Function OpenProcess Lib "kernel32" ( _
    ByVal dwAccess As Long, ByVal fInherit As Long, _
    ByVal IDProcess As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" ( _
    ByVal hProcess As Long, lpdwExitCode As Long) As Long


'アプリケーションの終了待ちをする関数

'引数
'hProcess : プロセスハンドル
'iTimeOut  : 待ち時間(秒)の上限。負数のとき上限なし。
'iFlag     : オプションフラグ
'            2: 待ちの間ユーザー操作を無効にする。
'            4: ESCキーによるキャンセルを有効にする。

'戻り値
' 0: 正常終了
'-1: 異常終了
'-2: ESCキーによるキャンセル
'-3: タイムアウト

Private Function WaitProcess( _
        ByVal hProcess As Long, _
        ByVal iTimeOut As Long, _
        ByVal iFlag As Long) As Long
    Dim dwExitCode As Long
    Dim bTimeOut As Boolean
    Dim iRet As Long
    Dim dateTimeOut As Date
    Dim oApp As Object
    Dim bInteractive As Boolean
    Dim iEnableCancelKey As Long

    WaitProcess = -1
    bTimeOut = False
    Set oApp = Application
    iEnableCancelKey = oApp.EnableCancelKey
    bInteractive = oApp.Interactive

    On Error GoTo ErrorHandler
    If (iFlag And 4&) = 0 Then
        oApp.EnableCancelKey = xlDisabled
    Else
        oApp.EnableCancelKey = xlErrorHandler
    End If
    If (iFlag And 2&) <> 0 Then
        oApp.Interactive = False
    End If

    If iTimeOut >= 0 Then
        dateTimeOut = Now + (iTimeOut / (24# * 60 * 60))
        Do
            DoEvents
            iRet = GetExitCodeProcess(hProcess, dwExitCode)
            If iRet = 0 Then
                GoTo Exit_Function
            End If
            If Now > dateTimeOut Then
                bTimeOut = True
                Exit Do
            End If
        Loop While (dwExitCode = STILL_ACTIVE)
    Else
        Do
            DoEvents
            iRet = GetExitCodeProcess(hProcess, dwExitCode)
            If iRet = 0 Then
                GoTo Exit_Function
            End If
        Loop While (dwExitCode = STILL_ACTIVE)
    End If
    iRet = CloseHandle(hProcess)
    If iRet = 0 Then
        GoTo Exit_Function
    End If
    hProcess = 0
    oApp.Interactive = bInteractive
    oApp.EnableCancelKey = iEnableCancelKey
    If bTimeOut Then
        WaitProcess = -3
    Else
        WaitProcess = 0
    End If
    Exit Function

Exit_Function:
    If hProcess <> 0 Then iRet = CloseHandle(hProcess)
    oApp.Interactive = bInteractive
    oApp.EnableCancelKey = iEnableCancelKey
    Exit Function

ErrorHandler:
    If Err = 18 Then WaitProcess = -2
    If hProcess <> 0 Then iRet = CloseHandle(hProcess)
    oApp.Interactive = bInteractive
    oApp.EnableCancelKey = iEnableCancelKey
    Exit Function
End Function


'終了待ちをするShell関数

'引数
'sCommand: Shell関数で使用するコマンド文字列
'nShow   : Shell関数で使用するウィンドウスタイル
'iTimeOut: 待ち時間(秒)の上限。負数のとき上限なし。

'戻り値
' 0: 正常終了
'-1: 異常終了
'-3: タイムアウト
'-4: Shell関数の失敗
' 1: OpenProcessの失敗
'    即終了するプログラムの場合は終了と見なすこともできます。

Public Function ShellWait( _
    ByVal sCommand As String, _
    ByVal nShow As Long, _
    ByVal iTimeOut As Long) As Long

    Dim IDProcess As Long
    Dim hProcess As Long
    Dim iRet As Long

    ShellWait = -1

    On Error Resume Next
    IDProcess = Shell(sCommand, nShow)
    iRet = Err
    On Error GoTo 0
    If iRet <> 0 Then
        ShellWait = -4
        Exit Function
    End If

    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 1, IDProcess)
    If hProcess = 0 Then
        ShellWait = 1
        Exit Function
    End If

    iRet = WaitProcess(hProcess, iTimeOut, 2)
    ShellWait = iRet
End Function


Public Function ShellExecuteWait( _
    ByVal sVerb As String, _
    ByVal sFile As String, _
    ByVal sParameters As String, _
    ByVal sDirectory As String, _
    ByVal nShow As Long, _
    ByVal iTimeOut As Long) As Long

    Dim sei As SHELLEXECUTEINFO
    Dim oApp As Object
    Dim iEnableCancelKey As Long
    Dim iRet As Long

    ShellExecuteWait = -1
    Set oApp = Application
    iEnableCancelKey = oApp.EnableCancelKey

    On Error GoTo ErrorHandler
    oApp.EnableCancelKey = xlErrorHandler

    With sei
        .cbSize = 60
        .fMask = SEE_MASK_FLAG_NO_UI Or SEE_MASK_NOCLOSEPROCESS
        .hwnd = GetDesktopWindow()
        .lpVerb = sVerb
        .lpFile = sFile
        .lpParameters = sParameters
        .lpDirectory = sDirectory
        .nShow = nShow
    End With

    iRet = ShellExecuteEx(sei)
    If iRet = 0 Then
        ShellExecuteWait = -4
        Exit Function
    End If

    iRet = WaitProcess(sei.hProcess, iTimeOut, 2)
    sei.hProcess = 0
    ShellExecuteWait = iRet
    Exit Function

ErrorHandler:
    If sei.hProcess <> 0 Then
        iRet = CloseHandle(sei.hProcess)
    End If
    oApp.EnableCancelKey = iEnableCancelKey
    Exit Function
End Function


'終了待ちをするShellExecute

'引数
'sFileName: ファイル名
'nShow    : 起動時のウィンドウスタイル
'iTimeOut : 待ち時間(秒)の上限。負数のとき上限なし。

'戻り値
' 0: 正常終了
'-1: 異常終了
'-3: タイムアウト
'-4: ShellExecuteの失敗

Public Function ShellOpenWait( _
    ByVal sFileName As String, _
    ByVal nShow As Long, _
    ByVal iTimeOut As Long) As Long

    ShellOpenWait = ShellExecuteWait( _
        sVerb:="open", _
        sFile:=sFileName, _
        sParameters:="", _
        sDirectory:="", _
        nShow:=nShow, _
        iTimeOut:=iTimeOut)
End Function


'テスト用プロシージャ

Sub Test_ShellWait1()
    Dim iRet As Long

    iRet = ShellWait("calc.exe", 1, 10)
    If iRet = 0 Then
        AppActivate Application.Caption
        MsgBox "アプリケーションが終了しました。", vbInformation
    ElseIf iRet = -3 Then
        MsgBox "タイムアウトが発生しました。", vbExclamation
    ElseIf iRet = 1 Then
        MsgBox "エラーまたはすでにアプリケーションは終了しています。", vbExclamation
    Else
        MsgBox "エラーが発生しました。", vbExclamation
    End If
End Sub


Sub Test_ShellWait2()
    Dim sTempFile As String
    Dim sCommand As String
    Dim iRet As Long

    sTempFile = "XLSLIST.TXT"
    If Dir$(sTempFile) <> "" Then
        iRet = MsgBox(sTempFile & " はすでに存在します。上書きしますか？", _
            vbOKCancel Or vbDefaultButton2 Or vbExclamation)
        If iRet <> vbOK Then Exit Sub
    End If

    sCommand = "command.com /c dir *.xls /on /b > " & sTempFile
    iRet = ShellWait(sCommand, 6, 40)

    AppActivate Application.Caption

    If iRet <> 0 Then
        MsgBox "エラーが発生しました。", vbExclamation
        Exit Sub
    End If

    Workbooks.Open sTempFile
End Sub


Sub Test_ShellOpenWait()
    Dim iRet As Long

    iRet = ShellOpenWait("C:\Windows\Tips.txt", 1, 10)
    If iRet = 0 Then
        AppActivate Application.Caption
        MsgBox "アプリケーションが終了しました。", vbInformation
    ElseIf iRet = -3 Then
        MsgBox "タイムアウトが発生しました。", vbExclamation
    Else
        MsgBox "エラーが発生しました。", vbExclamation
    End If
End Sub