Excel VBA で コマンドプロンプトを起動して、Excel からコマンドを入力して出力結果を Excel に表示する。
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