Redirecting stdout/stderr/stdin for child processes from within VB

[michals]

I thought of adding some of my code (based on some articles found in these forums) which I found very useful. I know a few people were looking for this sort of stuff so here it is.

enjoy
------------------------------------------------------

Option Explicit

Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
Private Const STARTF_USESHOWWINDOW = &H1&
Private Const SW_HIDE = 0
Private Const STARTF_USESTDHANDLES = &H100&
Private Const SYNCHRONIZE = 1048576
Private Const STD_INPUT_HANDLE = -10&
Private Const STD_OUTPUT_HANDLE = -11&
Private Const STD_ERROR_HANDLE = -12&
Private Const STILL_ACTIVE = &H103
Private Const DUPLICATE_SAME_ACCESS = &H2&
Private Const ERROR_BROKEN_PIPE = &H109&
Private Const PURGE_TXCLEAR = &H4&
Private Const PIPE_NOWAIT = &H1&

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As _ Long

Private Declare Function GetExitCodeProcess Lib "kernel32" _
    (ByVal hProcess As Long, lpExitCode As Long) As Long

Private Declare 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 Function CloseHandle Lib "kernel32" (ByVal _
    hObject As Long) As Long

Private Declare Function CreatePipe Lib "kernel32" ( _
    phReadPipe As Long, _
    phWritePipe As Long, _
    lpPipeAttributes As Any, _
    ByVal nSize As Long) As Long
      
Private Declare Function ReadFile Lib "kernel32" ( _
    ByVal hFile As Long, _
    ByVal lpBuffer As String, _
    ByVal nNumberOfBytesToRead As Long, _
    lpNumberOfBytesRead As Long, _
    ByVal lpOverlapped As Any) As Long
      
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function DuplicateHandle Lib "kernel32" (ByVal hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal hTargetProcessHandle As Long, lpTargetHandle As Long, ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function getLastError Lib "kernel32" Alias "GetLastError" () As Long
Private Declare Function SetNamedPipeHandleState Lib "kernel32" (ByVal hNamedPipe As Long, lpMode As Long, lpMaxCollectionCount As Long, lpCollectDataTimeout As Long) As Long

Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Private Type STARTUPINFO
   cb As Long
   lpReserved As Long
   lpDesktop As Long
   lpTitle As Long
   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 Long
   hStdInput As Long
   hStdOutput As Long
   hStdError As Long
End Type
      
Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
End Type

Public Function ExecCmd(cmdline As String, Optional stdout As Variant) As Long
    Dim proc As PROCESS_INFORMATION, ret As Long, bSuccess As Long
    Dim start As STARTUPINFO
    Dim sa As SECURITY_ATTRIBUTES
    Dim hStdErrWritePipe As Long, hStdErrReadPipe As Long
    Dim hStdOutReadPipe As Long, hStdOutWritePipe As Long
    Dim bytesread As Long, mybuff As String
    Dim i As Integer
    Dim result As Long

    sa.nLength = Len(sa)
    sa.bInheritHandle = 1&
    sa.lpSecurityDescriptor = 0&

    'create two pipes for input and output redirection
    If CreatePipe(hStdOutReadPipe, hStdOutWritePipe, sa, 0) = 0 Then
        ExecCmd = Err.LastDllError
        Exit Function
    End If

    'set non blocking mode on all pipe reads
    ret& = SetNamedPipeHandleState(hStdOutReadPipe, PIPE_NOWAIT, 0&, 0&)
    
    'Now we need to change the inheritable property for the readable end
    'of the pipe so that the child will not inherit that handle as a "garbage"
    'handle. This will keep us from having extra, unclosable handles to the pipe.
    'Alternatively, we could have opened the pipe with saPipe.bInheritHandle = FALSE
    'and changed the inherit property on the *write* handle of the pipe to TRUE.
    ret& = DuplicateHandle(GetCurrentProcess(), _
                           hStdOutReadPipe, _
                           GetCurrentProcess(), _
                           0&, _
                           0&, _
                           0&, _
                           DUPLICATE_SAME_ACCESS)
    
    'In most cases you can get away with using the same anonymous
    'pipe write handle for both the child's standard output and
    'standard error, but this may cause problems if the child app
    'explicitly closes one of its standard output or error handles.
    'If   that happens, the anonymous pipe will close, since the child's
    'standard output and error handles are really the same handle. The
    'Child won 't be able to write to the other write handle since the
    'pipe is now gone, and parent reads from the pipe will return
    'ERROR_BROKEN_PIPE and child output will be lost. To solve this
    'problem, simply duplicate the write end of the pipe to create
    'another distinct, separate handle to the write end of the pipe.
    'One pipe write handle will serve as standard out, the other as
    'standard error. Now *both* write handles must be closed before the
    'write end of the pipe actually closes.
    ret& = DuplicateHandle(GetCurrentProcess(), _
                           hStdOutReadPipe, _
                           GetCurrentProcess(), _
                           hStdErrWritePipe, _
                           0&, _
                           1&, _
                           DUPLICATE_SAME_ACCESS)
                           
    'set up process control block
    start.cb = Len(start)
    start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    
    'hStdInput needs a valid handle in case it is checked by the child
    start.hStdInput = hStdOutReadPipe
    start.hStdOutput = hStdOutWritePipe
    start.hStdError = hStdErrWritePipe
    start.wShowWindow = SW_HIDE
    
    ' Start the shelled application:
    ret& = CreateProcessA(0&, cmdline, sa, sa, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
    
    'while process is executing - collect it's output/error messages
    'Get the status of the process
    'Loop while the process is active
    
    'sleep for 1 seconds to give NT a chance to catch up with creating the process
    'also if a process terminates very quickly we want to give NT a chance to set it's
    'internals so we can detect that the process is already dead.
    DoEvents: Sleep 1000
    
    'find out the status of the process created above
    GetExitCodeProcess proc.hProcess, result
    
    'and if still running proceed to report it's stdout and stderr
    Do While result = STILL_ACTIVE
        'Sleep command recommended as well as DoEvents
        DoEvents: Sleep 500
    
        'initialise buffer
        mybuff = String(4096, Chr$(65))
        
        'make sure the process is still running
        GetExitCodeProcess proc.hProcess, result
        If result = STILL_ACTIVE Then
            ret& = ReadFile(hStdOutReadPipe, mybuff, 4096, bytesread, 0&)
        End If
        If ret And bytesread > 0 Then
            Call g_buildProgress.addMessage(VBA.Left(mybuff, bytesread))
        End If
        DoEvents: Sleep 1000
    
        'Loop while the process is active
        GetExitCodeProcess proc.hProcess, result
    Loop
        
    ' get return code and close handles
    ret& = CloseHandle(hStdOutWritePipe)
    ret& = CloseHandle(hStdErrWritePipe)
    ret& = CloseHandle(hStdOutReadPipe)
    ret& = GetExitCodeProcess(proc.hProcess, result)
    ret& = CloseHandle(proc.hProcess)
    ret& = CloseHandle(proc.hThread)

    'return success flag
    ExecCmd = result = 0
End Function

[BrunoJ]

First, thanks to michals for posting this. I realize this is an old post and he may not see the thanks, but I'll still express it.

I invite all comments to my posting. I am attempting to fully understand this before undertaking the sometimes arduous task of adapting it for use in VBA64.

That leads to my first observation - it appears as this was actually written for VBA, but adapted from VB. I say this because the function declaration for "getLastError" seems to serve no purpose in this context. My guess is its use was replaced by the "Err.LastDllError" method here. That and there is also an explicit use of "VBA.Left". Comments?

Most of the posting makes some sense until the "'make sure the process is still running" comment. Unless my understanding of stdin/stdout or what should be accomplished here is wrong (which I don't discount as a possibility), the ReadFile function should be called using hStdOutWritePipe, not hStdOutReadPipe. Also, there appears to be an object presumably defined in a different process as "g_buildProgress". I assume from the name that this is a progress reporting facility used during compilation, which makes little sense if this is VBA. Can anyone help with my confusion, please?