シェルが終了するのを待ってからセルをフォーマットします-コマンドを同期的に実行します

Question

Shellコマンドを使用して呼び出す実行可能ファイルがあります。

_Shell (ThisWorkbook.Path & "\ProcessData.exe")
_

実行可能ファイルはいくつかの計算を行い、結果をExcelにエクスポートして戻します。エクスポート後に結果の形式を変更できるようにしたい。

言い換えれば、実行可能ファイルがそのタスクを完了し、データをエクスポートし、次にフォーマットする次のコマンドを実行するまで、最初に待機するシェルコマンドが必要です。

Shellandwait()を試しましたが、あまり運はありませんでした。

私が持っていた：

_Sub Test()

ShellandWait (ThisWorkbook.Path & "\ProcessData.exe")

'Additional lines to format cells as needed

End Sub
_

残念ながら、それでも、実行可能ファイルが終了する前にフォーマットが最初に行われます。

参考までに、ここにShellandWaitを使用した完全なコードを示しました。

_' Start the indicated program and wait for it
' to finish, hiding while we wait.


Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Const INFINITE = &HFFFF


Private Sub ShellAndWait(ByVal program_name As String)
Dim process_id As Long
Dim process_handle As Long

' Start the program.
On Error GoTo ShellError
process_id = Shell(program_name)
On Error GoTo 0

' Wait for the program to finish.
' Get the process handle.
process_handle = OpenProcess(SYNCHRONIZE, 0, process_id)
If process_handle <> 0 Then
WaitForSingleObject process_handle, INFINITE
CloseHandle process_handle
End If

Exit Sub

ShellError:
MsgBox "Error starting task " & _
txtProgram.Text & vbCrLf & _
Err.Description, vbOKOnly Or vbExclamation, _
"Error"

End Sub

Sub ProcessData()

  ShellAndWait (ThisWorkbook.Path & "\Datacleanup.exe")

  Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
End Sub
_

Answer 1

ネイティブShell関数の代わりに WshShellオブジェクト を試してください。

Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim errorCode As Long

errorCode = wsh.Run("notepad.exe", windowStyle, waitOnReturn)

If errorCode = 0 Then
    MsgBox "Done! No error to report."
Else
    MsgBox "Program exited with error code " & errorCode & "."
End If    

ただし、次のことに注意してください。

bWaitOnReturnがfalse（デフォルト）に設定されている場合、Runメソッドはプログラムの起動直後に戻り、自動的に0を返します（エラーコードとして解釈されません）。

したがって、プログラムが正常に実行されたかどうかを検出するには、上記の例のようにwaitOnReturnをTrueに設定する必要があります。それ以外の場合は、何があってもゼロを返します。

事前バインディング（オートコンプリートへのアクセスを許可する）の場合、「Windowsスクリプトホストオブジェクトモデル」への参照を設定し（[ツール]> [参照]> [チェックマークの設定]）、次のように宣言します。

Dim wsh As WshShell 
Set wsh = New WshShell

ここでメモ帳の代わりにプロセスを実行します...システムがスペース文字（...\My Documents\...、...\Program Files\...など）を含むパスで動き回るので、パスを"quotes"で囲む必要があります。

Dim pth as String
pth = """" & ThisWorkbook.Path & "\ProcessData.exe" & """"
errorCode = wsh.Run(pth , windowStyle, waitOnReturn)

Answer 2

追加すると機能するものが機能します

Private Const SYNCHRONIZE = &H100000

あなたの行方不明。 （意味0は、無効なOpenProcessへのアクセス権として渡されています）

作成Option Explicitこの場合、すべてのモジュールの一番上の行でエラーが発生します。

Answer 3

Jean-FrançoisCorbettの有用な回答 で示されているWScript.Shellオブジェクトの.Run()メソッドは、呼び出すコマンドが予想どおりに終了することがわかっている場合に正しい選択です。時間枠。

以下はSyncShell()、タイムアウトを指定できる代替手段で、素晴らしい ShellAndWait() 実装に触発されています。 （後者は少々手がかかり、時にはよりスリムな代替が望ましいです。）

' Windows API function declarations.
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCodeOut As Long) As Integer

' Synchronously executes the specified command and returns its exit code.
' Waits indefinitely for the command to finish, unless you pass a 
' timeout value in seconds for `timeoutInSecs`.
Private Function SyncShell(ByVal cmd As String, _
                           Optional ByVal windowStyle As VbAppWinStyle = vbMinimizedFocus, _
                           Optional ByVal timeoutInSecs As Double = -1) As Long

    Dim pid As Long ' PID (process ID) as returned by Shell().
    Dim h As Long ' Process handle
    Dim sts As Long ' WinAPI return value
    Dim timeoutMs As Long ' WINAPI timeout value
    Dim exitCode As Long

    ' Invoke the command (invariably asynchronously) and store the PID returned.
    ' Note that this invocation may raise an error.
    pid = Shell(cmd, windowStyle)

    ' Translate the PIP into a process *handle* with the
    ' SYNCHRONIZE and PROCESS_QUERY_LIMITED_INFORMATION access rights,
    ' so we can wait for the process to terminate and query its exit code.
    ' &H100000 == SYNCHRONIZE, &H1000 == PROCESS_QUERY_LIMITED_INFORMATION
    h = OpenProcess(&H100000 Or &H1000, 0, pid)
    If h = 0 Then
        Err.Raise vbObjectError + 1024, , _
          "Failed to obtain process handle for process with ID " & pid & "."
    End If

    ' Now wait for the process to terminate.
    If timeoutInSecs = -1 Then
        timeoutMs = &HFFFF ' INFINITE
    Else
        timeoutMs = timeoutInSecs * 1000
    End If
    sts = WaitForSingleObject(h, timeoutMs)
    If sts <> 0 Then
        Err.Raise vbObjectError + 1025, , _
         "Waiting for process with ID " & pid & _
         " to terminate timed out, or an unexpected error occurred."
    End If

    ' Obtain the process's exit code.
    sts = GetExitCodeProcess(h, exitCode) ' Return value is a BOOL: 1 for true, 0 for false
    If sts <> 1 Then
        Err.Raise vbObjectError + 1026, , _
          "Failed to obtain exit code for process ID " & pid & "."
    End If

    CloseHandle h

    ' Return the exit code.
    SyncShell = exitCode

End Function

' Example
Sub Main()

    Dim cmd As String
    Dim exitCode As Long

    cmd = "Notepad"

    ' Synchronously invoke the command and wait
    ' at most 5 seconds for it to terminate.
    exitCode = SyncShell(cmd, vbNormalFocus, 5)

    MsgBox "'" & cmd & "' finished with exit code " & exitCode & ".", vbInformation


End Sub

Answer 4

私も簡単な解決策を探していましたが、最終的にこれらの2つの機能を作ることになりましたので、将来の愛好家の読者のために:)

1.）progが実行されている必要があり、DOSからタスクリストを読み取り、ステータスをファイルに出力し、VBAでファイルを読み取ります。

2.）progを起動し、wscriptシェル.exec waitonrunでprogが閉じられるまで待ちます

3.）tmpファイルを削除する確認を求めます

プログラム名とパス変数を変更し、一度に実行します。

Sub dosWOR_caller()

    Dim pwatch As String, ppath As String, pfull As String
    pwatch = "vlc.exe"                                      'process to watch, or process.exe (do NOT use on cmd.exe itself...)
    ppath = "C:\Program Files\VideoLAN\VLC"                 'path to the program, or ThisWorkbook.Path
    pfull = ppath & "\" & pwatch                            'extra quotes in cmd line

    Dim fout As String                                      'tmp file for r/w status in 1)
    fout = Environ("userprofile") & "\Desktop\dosWaitOnRun_log.txt"

    Dim status As Boolean, t As Double
    status = False

    '1) wait until done

    t = Timer
    If Not status Then Debug.Print "run prog first for this one! then close it to stop dosWORrun ": Shell (pfull)
    status = dosWORrun(pwatch, fout)
    If status Then Debug.Print "elapsed time: "; Format(Timer - t, "#.00s")

    '2) wait while running

    t = Timer
    Debug.Print "now running the prog and waiting you close it..."
    status = dosWORexec(pfull)
    If status = True Then Debug.Print "elapsed time: "; Format(Timer - t, "#.00s")

    '3) or if you need user action

    With CreateObject("wScript.Shell")
        .Run "cmd.exe /c title=.:The end:. & set /p""=Just press [enter] to delete tmp file"" & del " & fout & " & set/p""=and again to quit ;)""", 1, True
    End With

End Sub

Function dosWORrun(pwatch As String, fout As String) As Boolean
'redirect sdtout to file, then read status and loop

    Dim i As Long, scatch() As String

    dosWORrun = False

    If pwatch = "cmd.exe" Then Exit Function

    With CreateObject("wScript.Shell")
        Do
            i = i + 1

            .Run "cmd /c >""" & fout & """ (tasklist |find """ & pwatch & """ >nul && echo.""still running""|| echo.""done"")", 0, True

            scatch = fReadb(fout)

            Debug.Print i; scatch(0)

        Loop Until scatch(0) = """done"""
    End With

    dosWORrun = True
End Function

Function dosWORexec(pwatch As String) As Boolean
'the trick: with .exec method, use .stdout.readall of the WshlExec object to force vba to wait too!

    Dim scatch() As String, y As Object

    dosWORexec = False

    With CreateObject("wScript.Shell")

        Set y = .exec("cmd.exe /k """ & pwatch & """ & exit")

        scatch = Split(y.stdout.readall, vbNewLine)

        Debug.Print y.status
        Set y = Nothing
    End With

    dosWORexec = True
End Function

Function fReadb(txtfile As String) As String()
'fast read

    Dim ff As Long, data As String

    '~~. Open as txt File and read it in one go into memory
    ff = FreeFile
    Open txtfile For Binary As #ff
    data = Space$(LOF(1))
    Get #ff, , data
    Close #ff

    '~~> Store content in array
    fReadb = Split(data, vbCrLf)

    '~~ skip last crlf
    If UBound(fReadb) <> -1 Then ReDim Preserve fReadb(0 To UBound(fReadb) - 1)
End Function

Answer 5

VBAのシェルアンドウェイト _{^{（コンパクト版）}}

Sub ShellAndWait(pathFile As String)
    With CreateObject("WScript.Shell")
        .Run pathFile, 1, True
    End With
End Sub

---

使用例：

Sub demo_Wait()
    ShellAndWait ("notepad.exe")
    Beep 'this won't run until Notepad window is closed
    MsgBox "Done!"
End Sub

---

適応（およびその他のオプション） Chip Pearsonのサイト .