Option VBASupport 1
Option Explicit
Private Declare PtrSafe Function CreatePipe Lib "kernel32" ( _
phReadPipe As LongPtr, _
phWritePipe As LongPtr, _
lpPipeAttributes As Any, _
ByVal nSize As Long) As Long
Private Declare PtrSafe Function ReadFile Lib "kernel32" ( _
ByVal hFile As LongPtr, _
ByVal lpBuffer As String, _
ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, _
ByVal lpOverlapped As Any) As Long
Private Declare PtrSafe Function PeekNamedPipe Lib "kernel32" ( _
ByVal hNamedPipe As LongPtr, _
lpBuffer As Any, _
ByVal nBufferSize As Long, _
lpBytesRead As Long, _
lpTotalBytesAvail As Long, _
lpBytesLeftThisMessage As Long _
) As Long
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As LongPtr
bInheritHandle As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As LongPtr
lpDesktop As LongPtr
lpTitle As LongPtr
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 CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As Long, ByVal lpCommandLine As String, _
lpProcessAttributes As Any, lpThreadAttributes As Any, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
lpStartupInfo As Any, lpProcessInformation As Any) As Long
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal _
hObject As LongPtr) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib _
"kernel32" (ByVal hProcess As LongPtr, lpExitCode _
As Long) As Long
Private Const SW_SHOWNORMAL = 1
Private Const SW_HIDE = 0
Private Const STILL_ACTIVE = 259
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESHOWWINDOW = &H1&
Private Const STARTF_USESTDHANDLES = &H100&
Public Function ExecCmd(cmdline$) As String
Dim proc As PROCESS_INFORMATION, ret As Long, bSuccess As Long
Dim start As STARTUPINFO
Dim sa As SECURITY_ATTRIBUTES, hReadPipe As LongPtr, hWritePipe _
As LongPtr, hReadPipe2 As LongPtr, hWritePipe2 As LongPtr, ExitCode As Long, _
tBytesr As Long, tBytesa As Long, tMsg As Long, Result As Long
Dim bytesread As Long, mybuff As String
Dim i As Integer
mybuff = String(1024, "A")
sa.nLength = Len(sa)
sa.bInheritHandle = 1&
sa.lpSecurityDescriptor = 0&
ret = CreatePipe(hReadPipe, hWritePipe, sa, 0)
If ret = 0 Then
ExecCmd = "Error CreatePipe 1: " & Err.LastDllError
Exit Function
End If
start.hStdOutput = hWritePipe
ret = CreatePipe(hReadPipe2, hWritePipe2, sa, 0)
If ret = 0 Then
ExecCmd = "Error CreatePipe 2: " & Err.LastDllError
Exit Function
End If
start.hStdError = hWritePipe2
start.cb = Len(start)
start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
start.wShowWindow = SW_SHOWNORMAL
ret& = CreateProcessA(0&, cmdline$, sa, sa, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
If ret <> 1 Then
ExecCmd = "Error CreateProcessA: " & Err.LastDllError
Exit Function
End If
Do
GetExitCodeProcess proc.hProcess, ExitCode
Result = PeekNamedPipe(hReadPipe, ByVal 0&, 0&, ByVal 0&, tBytesa, ByVal 0&)
If Result <> 0 And tBytesa > 0 Then
bSuccess = ReadFile(hReadPipe, mybuff, 1024, bytesread, 0&)
If bSuccess = 1 Then
ExecCmd = ExecCmd & Left(mybuff, bytesread)
End If
End If
DoEvents
Loop While ExitCode = STILL_ACTIVE
ret& = CloseHandle(proc.hProcess)
ret& = CloseHandle(proc.hThread)
ret& = CloseHandle(hReadPipe)
ret& = CloseHandle(hWritePipe)
ret& = CloseHandle(hReadPipe2)
ret& = CloseHandle(hWritePipe2)
End Function
Sub test()
Dim result As String
result = ExecCmd("cmd.exe /c dir X* 2>&1")
MsgBox (result)
End Sub