Excel VBA でコマンドプロンプトを操作する

Excel VBA で コマンドプロンプトを起動して、Excel からコマンドを入力して出力結果を Excel に表示する。

```vb:10478256.xlsm
Option Explicit

Private Const HANDLE_FLAG_INHERIT = &H1
Private Const STARTF_USESTDHANDLES As Long = &H100&
Private Const WAIT_OBJECT_0 As Long = 0

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 LongPtr
    hStdInput As LongPtr
    hStdOutput As LongPtr
    hStdError As LongPtr
End Type

Private Type PROCESS_INFORMATION
    hProcess As LongPtr
    hThread As LongPtr
    dwProcessId As Long
    dwThreadId As Long
End Type

Private Declare PtrSafe Function SetHandleInformation Lib "kernel32" (ByVal hObject As LongPtr, ByVal dwMask As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CreatePipe Lib "kernel32" (ByRef phReadPipe As LongPtr, ByRef phWritePipe As LongPtr, ByVal lpPipeAttributes As Any, ByVal nSize As Long) As Long
Private Declare PtrSafe Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Any, ByVal lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByRef lpEnvironment As Any, ByVal lpCurrentDriectory As String, ByRef lpSTARTUPINFO As STARTUPINFO, ByRef lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare PtrSafe Function PeekNamedPipe Lib "kernel32" (ByVal hNamedPipe As LongPtr, ByRef lpBuffer As Any, ByVal nBufferSize As Long, ByRef lpBytesRead As Long, ByRef lpTotalBytesAvail As Long, ByRef lpBytesLeftThisMessage As Long) As Long
Private Declare PtrSafe Function ReadFile Lib "kernel32" (ByVal hFile As LongPtr, ByRef lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, ByVal lpOverlapped As Any) As Long
Private Declare PtrSafe Function WriteFile Lib "kernel32" (ByVal hFile As LongPtr, ByVal lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, ByRef lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetHandleInformation Lib "kernel32" (ByVal hObject As LongPtr, ByRef dwFlags As Long) As Long
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As LongPtr, ByVal dwMilliseconds As Long) As Long

Private InputCommand As String

Public Sub Execute()
    On Error GoTo ERROREXIT
    Dim p0r As LongPtr
    Dim p0w As LongPtr
    Dim p1r As LongPtr
    Dim p1w As LongPtr
    Dim si As STARTUPINFO
    Dim pi As PROCESS_INFORMATION
    Dim written As Long
    Dim avail As Long
    Dim buf() As Byte
    Dim read As Long
    Dim s As String
    Dim ss() As String
    Dim i As Long
    Dim r As Range
    If CreatePipe(p0r, p0w, 0&, 0) = 0 Then Call Err.Raise(513, , Err.LastDllError)
    If CreatePipe(p1r, p1w, 0&, 0) = 0 Then Call Err.Raise(514, Err.LastDllError)
    If SetHandleInformation(p0r, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT) = 0 Then Call Err.Raise(515, , Err.LastDllError)
    If SetHandleInformation(p1w, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT) = 0 Then Call Err.Raise(516, , Err.LastDllError)
    si.cb = LenB(si)
    si.hStdInput = p0r
    si.hStdOutput = p1w
    si.hStdError = p1w
    si.dwFlags = STARTF_USESTDHANDLES
    If CreateProcess("C:\Windows\System32\cmd.exe", "", 0&, 0&, 1&, 0&, 0&, "C:\", si, pi) = 0 Then Call Err.Raise(517, , Err.LastDllError)
    Call CloseHandle(pi.hThread)
    pi.hThread = 0
    While WaitForSingleObject(pi.hProcess, 0) <> WAIT_OBJECT_0
        If PeekNamedPipe(p1r, 0&, 0&, 0&, avail, 0&) = 0 Then Call Err.Raise(518, , Err.LastDllError)
        If avail = 0 Then
            DoEvents
            If InputCommand <> "" Then
                If WriteFile(p0w, InputCommand & vbCrLf, Len(InputCommand) + 2, written, 0&) = 0 Then Call Err.Raise(519, , Err.LastDllError)
                InputCommand = ""
            End If
        Else
            ReDim buf(0 To avail)
            If ReadFile(p1r, buf(0), avail, 0&, 0&) = 0 Then Call Err.Raise(520, , , Err.LastDllError)
            s = StrConv(buf, vbUnicode)
            ss = Split(s, vbLf)
            For i = LBound(ss) To UBound(ss)
                Set r = ActiveCell
                Call r.offset(1, 0).Select
                r.Value2 = r.Value2 & ss(i)
                InputCommand = ""
            Next i
        End If
    Wend
ERROREXIT:
    If pi.hProcess <> 0 Then Debug.Print "pi.hProcess", CloseHandle(pi.hProcess)
    If pi.hThread <> 0 Then Debug.Print "pi.hThread", CloseHandle(pi.hThread)
    If p0r <> 0 Then Debug.Print "p0r", CloseHandle(p0r)
    If p0w <> 0 Then Debug.Print "p0w", CloseHandle(p0w)
    If p1r <> 0 Then Debug.Print "p1r", CloseHandle(p1r)
    If p1w <> 0 Then Debug.Print "p1w", CloseHandle(p1w)
    Debug.Print Err.Number, Err.Source, Err.Description, Err.HelpContext
    If Err.Number <> 0 Then Call Err.Raise(Err.Number, Err.Source, Err.Description, Err.HelpContext)
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    InputCommand = Target.Text
End Sub

```