It’s all made out of pipes

TLDR: This post is about redirecting stdin, stdout and stderr in Visual Basic. There are links to the source down the bottom.

So these things called pipes exist, and they’re used by every executable made in the last 40 years to send information in and out of themselves.

In a former life, one of my slightly more intelligible bosses used to create things called ‘egg diagrams’, which was essentially a circle (the egg), which represented whatever project we were trying to create specifications for, with maybe 4 or 5 different arrows going into or out of the egg denoting how people and other systems exchange data with the egg/circle/very reasonably priced software project.

It probably helps if it’s on a whiteboard.

These were normally extremely high level, so you’d have one arrow for ‘users’, one for ‘some kind of database’, one for ‘authentication server’, one for ‘rotating knives‘, that sort of thing.

So the egg diagram for a process as far as I want to get into things today would look like this:

Standard input and output streams (as described in pages 1-149381723 of the manual).
Standard input and output streams (as described in pages 1-149381723 of the manual).

Which is surprisingly difficult to get right for some languages.

VB, for one. It’s got a builtin command ‘Shell’, which allows you to kick off a process, but that’s about it. If you want to write to the process’s standard input or read its standard output or standard error handles/streams/file descriptors, then you need to use cmd’s redirect facilities (“<", ">“, “|”) to temporary files and then read the files afterwards, which is a bit suboptimal, and doesn’t work in some use-cases. Here’s a module I wrote up in VBA6 which gives you the ability to write to stdin and read stderr/stdout from a Windows process. It doesn’t use .NET.

I’m providing it here in two flavours, one as a module (for simple redirection of stdin/stdout/stderr), and one as a class, which provides an event-driven interface for more complex interactions and adds features like timeouts.

This is a screenshot of an MSAccess form containing the class-based process object, text boxes containing the output streams, and a standard ‘file copy’ animation which gives the user some feedback whilst the process is executing. (Update: I’ve included a list of resource IDs and system AVIs in this blog post)

The source code for this form and the supporting modules are at the bottom of this blog post.

frmProcessTest
frmProcessTest

The Module

The module should be easy enough; just cut and paste the source code into your Access/Excel/Word/Powerpoint/other-VBA-enabled-program, and then you can call other executables using the fncRedirectProcess function. It returns a RedirectProcessResult object.

Dim rpr As RedirectProcessResult
rpr = new RedirectProcessResult
' You wouldn't normally call 'cmd' here; just call whatever program you want to run directly.
' (I'm just using a command-line program that everyone should have already installed, 
' i.e. the Windows command shell)
Debug.Print "Calling cmd process..."
Set rpr = fncRedirectProcess("cmd", "", _
  "echo hello" & vbCrLf & _
  "set" & vbCrLf & _
  "this-program-doesnt-exist" & vbCrlf & _
  "exit 1" & vbCrLf, _
  True, True)  ' boolShowWindow, boolSeparateStdoutStderr
Debug.Print "Process complete"
Debug.Print "rpr.strCommandLine=" & rpr.strCommandLine
Debug.Print "rpr.lngErrNumber=" & rpr.lngErrNumber
Debug.Print "rpr.strErrDescription=" & rpr.strErrDescription
Debug.Print "rpr.lngErrExitCode=" & rpr.lngExitCode
Debug.Print "rpr.strStdOut=" & rpr.strStdOut
Debug.Print "rpr.strStdErr=" & rpr.strStdErr

which should give you output that looks similar to the following (notice the environment block).

Calling cmd process...
Process complete
rpr.strCommandLine="cmd" 
rpr.lngErrNumber=0
rpr.strErrDescription=
rpr.lngErrExitCode=1
rpr.strStdOut=Microsoft Windows XP [Version 5.1.2600]
(C) Copyright 1985-2001 Microsoft Corp.
 
C:\transfer\2013-10-03-cvs>echo hello
hello
 
C:\transfer\2013-10-03-cvs>set
COMSPEC=C:\WINDOWS\system32\cmd.exe
PATHEXT=.COM;.EXE;.BAT;.CMD;.VBS;.JS;.WS
PROMPT=$P$G
SystemRoot=C:\WINDOWS
 
C:\transfer\2013-10-03-cvs>this-program-doesnt-exist
 
C:\transfer\2013-10-03-cvs>exit
 
rpr.strStdErr='this-program-doesnt-exist' is not recognized as an internal or external command,
operable program or batch file.

The parameters to the function, in the time-honoured Microsoft™ formatting, terminology and dry sense of clinical accuracy before they started throwing Clippy, ribbons, tiles and other user-derived-opti-sensed-vacu-context internet-based help systems into the mix, are:

fncRedirectProcess Function

See AlsoExampleSpecifics

Runs an executable program and returns a RedirectProcessResult user-defined type containing the program’s output and exit codes.

Syntax

fncRedirectProcess(strApplicationName, strArguments [ ,strStdIn [ ,boolShowWindow [ ,boolSeparateStdoutStderr ]]])

The fncRedirectProcess function syntax has these named arguments:

Part Description
strApplicationName Required; String. Name of the program to execute.

Standard CreateProcess rules apply when searching for the application:

If the file name does not contain an extension, .exe is appended. Therefore, if the file name extension is .com, this parameter must include the .com extension. If the file name ends in a period (.) with no extension, or if the file name contains a path, .exe is not appended. If the file name does not contain a directory path, the system searches for the executable file in the following sequence:

  • The directory from which the application loaded.
  • The current directory for the parent process.
  • The 32-bit Windows system directory. The name of this directory is usually System32
  • The 16-bit Windows system directory. The name of this directory is System.
  • The Windows directory.
  • The directories that are listed in the PATH environment variable.

Note that this function does not search the per-application path specified by the App Paths registry key.

strArguments Required; String. Any arguments or command-line switches
strStdIn Optional; String. A string containing the data to be written to the standard input handle of the process. If strStdIn is omitted, the standard input is the empty string (“”).
boolShowWindow Optional; Boolean. If True, will display the process window as the process is running. If boolShowWindow is omitted, the window is not shown.
boolSeparateStdoutStderr Optional; Boolean. If True, the function will separate the standard output and standard error streams in the strStdOut and strStdErr elements of the returned RedirectProcessResult object, otherwise both streams will be interleaved in the strStdOut element.

If boolSeparateStdoutStderr is omitted, the streams are not separated.

Remarks

The fncRedirectProcess function creates a Windows child process and redirects its standard input, output and error handles.

The process will run synchronously. This means the function will not return until the child process has terminated (or an internal error has occurred).

If the process was created and terminated successfully, the value of the lngErrNumber element will be zero.

If lngErrNumber is zero, the result of the child process can be determined by inspecting the value of the lngExitCode element. Any data written by the process to its standard output and error handles will be contained in the strStdOut and strStdErr elements, respectively.

Even if the process window is displayed (due to the boolShowWindow being set to True) normal output may not be visible in the window, since it is redirected by this function.

The fncRedirectProcess function will return a RedirectProcessResult user-defined type, containing the following elements:

Part Description
strCommandLine String. The complete command line which was passed to the Windows CreateProcess function.

The command line is composed of the concatenation of the strApplicationName enclosed in double quotes, a space, and the value of the strArguments.

strStdOut String. The standard output generated by the process.
strStdErr String. The standard error generated by the process.
lngExitCode Long. The exit code of the process.

In Windows, a non-zero exit code conventionally denotes an error condition within the program. See the documentation for the specific process for more information.

lngErrNumber Long. If this value is non-zero, an error occurred launching or handling the process in the fncRedirectProcess function itself. If this occurs, you can refer to strErrDescription for a text description of the error.
strErrDescription String. If the value of lngErrNumber is non-zero, this element will contain a text description of the error that occurred.

The Class

The clsProcess class is slightly more complex but has a few more features. It provides a number of events (Tick, StdOutAvailable, StdErrAvailable), which are triggered by the class as the process executes.

In it’s simplest form, it’s similar to fncRedirectProcess, except instead of returning a RedirectProcessResult, you retrieve information from the class itself.

Dim clsProcess As clsProcess
p = new clsProcess
' You wouldn't normally call 'cmd' here; just call whatever program you want to run directly.
' (I'm just using a command-line program that everyone should have already installed, 
' i.e. the Windows command shell)
p.ApplicationName = "cmd"
p.Arguments = ""
p.StdIn = "echo hello" & vbCrLf & _
  "set" & vbCrLf & _
  "this-program-doesnt-exist" & vbCrlf & _
  "exit 1" & vbCrLf
Debug.Print "Calling cmd process..."
p.Execute
Debug.Print "Process complete"
Debug.Print "p.ApplicationName=" & p.ApplicationName
Debug.Print "p.Arguments=" & p.Arguments
Debug.Print "p.ErrNumber=" & p.errNumber
Debug.Print "p.ErrDescription=" & p.errDescription
Debug.Print "p.ErrExitCode=" & p.ExitCode
Debug.Print "p.StdOut=" & p.StdOut
Debug.Print "p.StdErr=" & p.StdErr

which gives similiar output to the fncRedirectProcess() example above.

If you prefer, you could use the event interface, which allows you to read stdout/stderr as the process runs, allowing you to update progress bars or provide other feedback to the user, or to send/receive data to interactive commands (similar to the unix ‘expect‘ command), or who knows, get your computer to do two things at the same time.

The frmProcess screenshot at the top of this blog entry is an example of what is possible using the clsProcess class.

Seeing as I don’t have a fleet of technical writers whose job it is document this thing in 12 different languages, I’ve only written up some documentation for the main class itself, and a couple of the properties. I may update this at a later time.

clsProcess Object

See AlsoExamplePropertiesMethodsEvents

A clsProcess object represents an executable program, its invocation, output and exit codes.

Remarks

You can create, execute and evaluate the result of processes using the clsProcess object.

In order to use the object, you should:

  1. Create a new clsProcess object.
  2. Set any Properties required prior to the invocation of the process:
    • Assign a value to the ApplicationName property containing the filename of the process to be created.
    • Optionally, assign a value to the Arguments property if any command-line arguments are to be supplied to the application.
    • If any input is to be supplied to the standard input of the process at startup, assign a value to the StdIn property.
    • If the process window is to be shown, assign the value True to the ShowWindow property.
    • If the standard output and standard error streams should be separated, assign the value True to the SeparateStdoutStderr property.
    • If the process is to be automatically terminated after a period of inactivity, assign a value to the TimeoutMillis property.
  3. Call the Execute method.
    • If the calling application needs to process output as it is created, handle the StdoutAvailable event.
    • If the calling application needs to process error output as it is created, handle the StderrAvailable event.
    • If the calling application needs to perform other periodic tasks whilst the process is executing, handle the Tick event.

      The delay between tick counts can be set using the TickWaitMillis property.

      The current tick count can be read from the TickCount property. The tick count when the data was last received on the standard output or standard input handles can be read from the LastOutputTickCount property.

    • If the calling application needs to terminate the process, call the Terminate method during any of the event handlers above.
  4. Once the process has completed, inspect the ErrNumber, ErrDescription, ExitCode, StdOut, StdErr and Terminated properties.

It is an error to set the value of the SeparateStdoutStderr, ShowWindow, Arguments, StdIn or TickWaitMillis properties whilst the Execute method is running.

It is an error to get the value of the ExitCode, ErrNumber, ErrDescription properties whilst the Execute method is running.

You may reuse clsProcess objects for multiple executions of processes. Properties can be modified between invocations.

You can determine whether a process exited normally or was terminated (either by a timeout or by the Terminate method) by checking the Terminated property.

If the clsProcess object goes out of scope or is otherwise destroyed (e.g. by setting it to Null), then any running Windows process referenced by that clsProcess object is terminated.

If an internal error occurs, it is possible for the Execute method to return without properly terminating the Windows process, or closing all handles to that process. The values of the ErrNumber and ErrDescription properties may be used to determine the cause of the internal error.

Execute Method

See AlsoExampleApplies ToSpecifics

Execute a clsProcess.

expression.Execute
expression Required. An expression that returns one of the objects in the Applies To list.
Remarks

See the class documentation.

Example

See the blog post.

StdoutAvailable Event

A StdoutAvailable event occurs when a clsProcess is executing a Windows process during a call to Execute, and the child process writes data to the standard output handle (or to the standard error handle if the clsProcess has the SeparateStdoutStderr property set to False).

Private Sub object_StdoutAvailable(strText)
object The name of a clsProcess.
strText String. The data sent to standard output since the last StdoutAvailable event.
Remarks

Only the output received since the last StdoutAvailable event is returned (or since the Execute method if no previous event has occurred). The complete (cumulative) data written to the standard output handle can be read from the StdOut property if required.

StdoutAvailable events will not occur less than TickWaitMillis milliseconds apart (by default, 100 milliseconds). See the section marked ‘Timing’ below.

Additional input can be sent to the process using the SendInput method.

To perform activity whilst no output is received, use the Tick event.

The child Windows process can be signalled for termination by calling the Terminate method within the StdoutAvailable event handler.

Timing

Responsiveness may be improved by reducing TickWaitMillis.

CPU usage may be reduced by increasing TickWaitMillis.

Buffering of output by the child process may increase the time between when data is written to standard output, and when this event occurs.

The TickWaitMillis property does not include time spent inside any clsProcess event handlers.

The TickWaitMillis property can be set before calling Execute, or modified during the StdoutAvailable event handler.

The current tick count can be retrieved by reading the TickCount property.

The last tick count in which any output was written to standard output or standard error can be retrieved by reading the LastOutputTickCount property.

TimeoutMillis Property

See AlsoApplies ToExample

You can use the TimeoutMillis property of a clsProcess object to specify or determine the amount of idle time in milliseconds that can elapse before a process will be terminated.

expression.TimeoutMillis
expression Required. An expression that returns one of the objects in the Applies To list.
Setting

This property setting contains a Long value representing a duration in milliseconds. If no data is received on either the standard output or standard error handles for at least this duration, then the process will be forcibly terminated.

This property is read/write.

Remarks

Foribly terminating a process will interrupt any processing it may be performing. This may, for example, leave application disk file structures in an inconsistent state, or cause other data to be corrupted.

If no timeout is to be applied or an existing timeout is to be cleared/cancelled, use a negative or zero value for TimeoutMillis.

The TimeoutMillis property does not include time spent inside any clsProcess event handlers.

Timeouts will only have a resolution as precise as the current value of the TickWaitMillis property (e.g. a TimeoutMillis value of 50 and a TickWaitMillis of 100 will time out in 100 milliseconds, not 50 milliseconds).

It is recommended that the TickWaitMillis property not be modified during a timeout. If this property is modified during a timeout, then the actual duration of the timeout is not specified.

The Tick event handler can also cause a process to be terminated by calling the Terminate method.

The presence of a Tick event handler will not, in and of itself, cancel any timeouts on a clsProcess object, although it may cancel a timeout by setting the TimeoutMillis property to zero.

If a process is terminated by exceeding its timeout, then the value of the Terminated property will be True

Here’s the code already.

mdlProcess.vba
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
Option Compare Database
Option Explicit
 
' (c) 2013 randomnoun. All Rights Reserved. This work is licensed under a
' BSD Simplified License. (http://www.randomnoun.com/bsd-simplified.html)
 
'' A module to allow Win32 processes to be created, executed, and have their stdin/stdout/stderr
' streams redirected.
'
' <p>This example opens a command shell (cmd), then sends commands to view environment
' variables within the shell (set), attempts to invoke an invalid program (arg), and exit
' the shell (exit). The instructions to the command shell are passed in via stdin:
'
' <pre>
' Dim rpr As RedirectProcessResult
' rpr = fncRedirectProcess "cmd", "", "set" & vbCrLf & "arg" & vbCrLf & "exit" & vbCrLf, false, False
' If rpr.lngErrNumber<>0 Or rpr.lngExitCode<>0 then
'   MsgBox "Error occurred: " & rpr.strErrDescription
' Else
'   MsgBox "Command succeeded. stdout=" & rpr.strStdOut & ", stderr=" & rpr.strStdErr
' Endif
' </pre>
'
' <p>Note that the environment block from the calling process is *not* supplied to the process, since
' this doesn't seem to actually work. The %SystemRoot% environment variable will be set.
'
' @blog http://www.randomnoun.com/wp/2013/10/07/its-all-made-out-of-pipes/
' @author knoxg
' @version $Id$
 
' see http://www.randomnoun.com/wp/2013/10/07/its-all-made-out-of-pipes/
' for further documentation for this class
 
' Uses code from
'  http://pastebin.com/CszKUpNS - redirect stdout
'  http://support.microsoft.com/kb/252652 - get folder via CSIDL value
'  http://msdn.microsoft.com/en-us/library/windows/desktop/ms682425%28v=vs.85%29.aspx - CreateProcess
'  http://support.microsoft.com/kb/173085 - reading/writing pipes
'  http://msdn.microsoft.com/en-us/library/ms682499.aspx - readin/writing pipes (2)
'  http://support.microsoft.com/kb/q129796 - determine when process is complete
'  http://support.microsoft.com/kb/190351 - duplicate handles during redirection
 
' result user-defined type
 
Public Type RedirectProcessResult
  strCommandLine As String
  strStdOut As String
  strStdErr As String
  lngExitCode As Long ' process exit code if invocation successful
  lngErrNumber As Long ' invocation error code; 0=success
  strErrDescription As String ' if lngError <> 0
End Type
 
 
' Windows structures/constants/declarations
 
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
 
Private Type PROCESS_INFORMATION
    hProcess As Long
    hThStdoutRead As Long
    dwProcessId As Long
    dwThStdoutReadId 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 Byte
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type
 
Private Const WAIT_INFINITE         As Long = (-1&)
Private Const STARTF_USESHOWWINDOW  As Long = &H1
Private Const STARTF_USESTDHANDLES  As Long = &H100
Private Const SW_HIDE               As Long = &H0
Private Const SW_NORMAL             As Long = &H1
Private Const HANDLE_FLAG_INHERIT   As Long = &H1
Private Const HANDLE_FLAG_PROTECT_FROM_CLOSE As Long = &H2
Private Const DUPLICATE_SAME_ACCESS         As Long = &H2
Private Const NORMAL_PRIORITY_CLASS As Long = &H20
Private Const CREATE_UNICODE_ENVIRONMENT As Long = &H400
Private Const CREATE_NEW_PROCESS_GROUP As Long = &H200
 
Private Const CSIDL_WINDOWS         As Long = &H24
Private Const MAX_PATH              As Long = 260
Private Const SHGFP_TYPE_CURRENT    As Long = &H0
Private Const SHGFP_TYPE_DEFAULT    As Long = &H1
 
Private Const ERROR_NO_DATA         As Long = 232 ' winerror.h
 
Private Declare Function CreatePipe Lib "kernel32" (phStdoutReadPipe As Long, phStdoutWritePipe As Long, lpPipeAttributes As SECURITY_ATTRIBUTES, ByVal nSize As Long) As Long
Private Declare Function SetHandleInformation Lib "kernel32" (ByVal hObject As Long, ByVal dwMask As Long, ByVal dwFlags 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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
 
Private Declare Function SHGetFolderPath Lib "shfolder" Alias "SHGetFolderPathA" (ByVal hwndOwner As Long, ByVal nFolder As Long, ByVal hToken As Long, ByVal dwFlags As Long, ByVal pszPath As String) As Long
Private Declare Sub GetStartupInfo Lib "kernel32" Alias "GetStartupInfoA" (lpStartupInfo As STARTUPINFO)
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThStdoutReadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
 
' this works
' fncRedirectProcess "cmd", "", "echo hello" & vbcrlf & "exit"& vbcrlf
' but cvsnt doesn't.  ah. now it does.
 
'' So this thing kicks off a process and captures the output in some intelligible form
'
' @param strApplicationName
' @param strArguments
' @param strStdin
' @param boolShowWindow
' @param boolSeparateStdoutStderr
 
Public Function fncRedirectProcess(strApplicationName As String, strArguments As String, _
  Optional strStdIn As String = "", Optional boolShowWindow As Boolean = False, _
  Optional boolSeparateStdoutStderr As Boolean = False) As RedirectProcessResult
 
  Dim saProcess       As SECURITY_ATTRIBUTES
  Dim saThread        As SECURITY_ATTRIBUTES
  Dim saPipe          As SECURITY_ATTRIBUTES
  Dim tProcessInfo    As PROCESS_INFORMATION
  Dim tStartupInfo    As STARTUPINFO
  Dim hStdoutReadTmp As Long, hStderrReadTmp As Long, hStdinWriteTmp As Long
  Dim hStdoutRead As Long, hStderrRead As Long, hStdinRead As Long
  Dim hStdoutWrite As Long, hStderrWrite As Long, hStdinWrite As Long
  Dim lngReadBytes    As Long
  Dim abytReadBuf()   As Byte
  Dim strWriteBuf     As String
  Dim lngResult, lngResult2 As Long
  Dim strFullCommandLine  As String
  Dim lngExitCode     As Long
  Dim lngSizeOf       As Long
  Dim strPath         As String
  Dim strEnv          As String
  Dim abytEnv()       As Byte
 
  fncRedirectProcess.lngExitCode = -1
  fncRedirectProcess.lngErrNumber = 0
  fncRedirectProcess.strErrDescription = ""
 
  ' input validation
  If (strApplicationName = "") Then subSetError fncRedirectProcess, 100, "Missing strApplicationName"
  If (fncRedirectProcess.lngErrNumber <> 0) Then Exit Function
 
  ' assign default security descriptor associated with access token of the calling process.
  saPipe.nLength = Len(saPipe)
  saPipe.bInheritHandle = 1&
  saPipe.lpSecurityDescriptor = 0&
 
  saProcess.nLength = Len(saProcess)
  saProcess.bInheritHandle = 1&
  saProcess.lpSecurityDescriptor = 0&
 
  saThread.nLength = Len(saThread)
  saThread.bInheritHandle = 1&
  saThread.lpSecurityDescriptor = 0&
 
  ' create pipes
 
  ' for stdout (and possibly stderr)
  If (CreatePipe(hStdoutReadTmp, hStdoutWrite, saPipe, 0&) = 0&) Then
    subSetError fncRedirectProcess, 1, "CreatePipe failes on tmp stdout"
    Exit Function
  End If
 
  ' for stderr
  If boolSeparateStdoutStderr Then
    ' separate stdout/stderr pipes
    If (CreatePipe(hStderrReadTmp, hStderrWrite, saPipe, 0&) = 0&) Then
      subSetError fncRedirectProcess, 2, "CreatePipe failed on tmp stderr"
      Exit Function
    End If
  Else
    ' create a duplicate of the stdout handle here for stderr
    ' (in case child decides to close one of them)
    If (DuplicateHandle(GetCurrentProcess(), hStdoutWrite, GetCurrentProcess(), hStderrWrite, 0, True, DUPLICATE_SAME_ACCESS) = 0&) Then
      subSetError fncRedirectProcess, 3, "DuplicateHandle failed on stdout/stderr"
      Exit Function
    End If
  End If
 
  ' for stdin
  If (CreatePipe(hStdinRead, hStdinWriteTmp, saPipe, 0&) = 0&) Then
    subSetError fncRedirectProcess, 4, "CreatePipe failed on tmp stdin"
    Exit Function
  End If
 
  ' duplicate handles: get the "real" handles from the tmp handles, with Properties
  ' set to FALSE. this gives us closeable handles to the pipes.
  ' see http://support.microsoft.com/kb/190351
  If (DuplicateHandle(GetCurrentProcess(), hStdoutReadTmp, GetCurrentProcess(), hStdoutRead, 0, False, DUPLICATE_SAME_ACCESS) = 0&) Then
    subSetError fncRedirectProcess, 5, "DuplicateHandle failed on stdout"
    Exit Function
  End If
 
  If boolSeparateStdoutStderr Then
    If (DuplicateHandle(GetCurrentProcess(), hStderrReadTmp, GetCurrentProcess(), hStderrRead, 0, False, DUPLICATE_SAME_ACCESS) = 0&) Then
      subSetError fncRedirectProcess, 6, "DuplicateHandle failed on stderr"
      Exit Function
    End If
  End If
  If (DuplicateHandle(GetCurrentProcess(), hStdinWriteTmp, GetCurrentProcess(), hStdinWrite, 0, False, DUPLICATE_SAME_ACCESS) = 0&) Then
    subSetError fncRedirectProcess, 7, "DuplicateHandle failed on stdin"
    Exit Function
  End If
 
  ' Close inheritable copies of the handles we do not want to be inherited.
  If (CloseHandle(hStdoutReadTmp) = 0) Then
    subSetError fncRedirectProcess, 8, "CloseHandle failed on tmp stdout"
    Exit Function
  End If
  ' again, probably don't do this if we're using same handle for stdout/err
  If boolSeparateStdoutStderr Then
    If (CloseHandle(hStderrReadTmp) = 0) Then
      subSetError fncRedirectProcess, 9, "CloseHandle failed on tmp stderr"
      Exit Function
    End If
  End If
  If (CloseHandle(hStdinWriteTmp) = 0) Then
    subSetError fncRedirectProcess, 10, "CloseHandle failed on tmp stdin"
    Exit Function
  End If
 
  tStartupInfo.cb = Len(tStartupInfo)
  GetStartupInfo tStartupInfo
  tStartupInfo.cb = Len(tStartupInfo)
  tStartupInfo.hStdOutput = hStdoutWrite
  tStartupInfo.hStdError = hStderrWrite
  tStartupInfo.hStdInput = hStdinRead
  tStartupInfo.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
  tStartupInfo.wShowWindow = IIf(boolShowWindow, SW_NORMAL, SW_HIDE)
 
  ' full command sent to CreateProcess
  strFullCommandLine = """" & strApplicationName & """" & " " & strArguments
  fncRedirectProcess.strCommandLine = strFullCommandLine
 
  ' define SystemRoot environment variable.
  ' if this isn't here, then TCP network applications will fail with the error
  '   The requested service provider could not be loaded or initialized.
  ' because it can't load mswsock.dll (the path to it contains "%SystemRoot" in the protocol section of the winsock registry)
  ' the other env vars that always seem to be set by CreateProcess (or possibly cmd.exe, which I used for testing) are
  '   "COMSPEC=C:\WINDOWS\system32\cmd.exe" & Chr(0) & _
  '   "PATHEXT=.COM;.EXE;.BAT;.CMD;.VBS;.JS;.WS" & Chr(0) & _
  '   "PROMPT=$P$G" & Chr(0) &
  strPath = String(MAX_PATH, 0)
  If (SHGetFolderPath(0, CSIDL_WINDOWS, 0, SHGFP_TYPE_CURRENT, strPath) <> 0) Then
    subSetError fncRedirectProcess, 11, "SHGetFolderPath failed"
    Exit Function
  End If
  strPath = Left(strPath, InStr(1, strPath, Chr(0)) - 1) ' just up to null terminator
  strEnv = "SystemRoot=" & strPath & Chr(0) & Chr(0)  ' sz terminator + env block terminator
  abytEnv = StrConv(strEnv, vbFromUnicode)            ' encode as byte array
 
  ' if the executable module is a 16-bit application, lpApplicationName should be NULL
  lngResult = CreateProcess(0&, strFullCommandLine, saProcess, saThread, 1&, _
    NORMAL_PRIORITY_CLASS, abytEnv(0), vbNullString, tStartupInfo, tProcessInfo)
  If (lngResult = 0&) Then
    subSetError fncRedirectProcess, 12, "CreateProcess failed"
    Exit Function
  End If
 
  ' XXX: possibly terminate process if errors occur from here on
 
  ' Close pipe handles (do not continue to modify the parent).
  ' We need to make sure that no handles to the write end of the output pipe are maintained
  ' in this process or else the pipe will not close when the child process exits.
  ' Probably not an issue since we don't use a blocking ReadFile later, but this is consistent
  ' with the microsoft kb article above.
  If (CloseHandle(hStdoutWrite) = 0) Then
    subSetError fncRedirectProcess, 13, "CloseHandle failed"
    Exit Function
  End If
  If (CloseHandle(hStdinRead) = 0) Then
    subSetError fncRedirectProcess, 14, "CloseHandle failed"
    Exit Function
  End If
  If (CloseHandle(hStderrWrite) = 0) Then
    subSetError fncRedirectProcess, 15, "CloseHandle failed"
    Exit Function
  End If
 
  ' first first stdin block; TODO: may exceed buffer size ?
  If (WriteFile(hStdinWrite, ByVal strStdIn, Len(strStdIn), lngResult, ByVal 0&) = 0) Then
    subSetError fncRedirectProcess, 16, "WriteFile failed"
    Exit Function
  End If
 
  lngResult = WaitForSingleObject(tProcessInfo.hProcess, 100)  ' 100ms
  Do
    DoEvents
    Select Case lngResult
      Case 258& ' 500ms timeout
        ' keep on trucking.
        lngResult = WaitForSingleObject(tProcessInfo.hProcess, 100)
      Case &H80, &HFFFFFFFF  ' abandoned / failed
        subSetError fncRedirectProcess, 17, "Wait abandoned/failed (" & lngResult & ")"
        Exit Function
      Case 0
        ' wait complete
      Case Else
        subSetError fncRedirectProcess, 18, "WaitForSingleObject failed (" & lngResult & ")"
        lngExitCode = -5
        Exit Function
    End Select
 
    ' pump the i/o stream pipes
    lngSizeOf = GetFileSize(hStdoutRead, 0&)
    If (lngSizeOf > 0) Then
      ReDim abytReadBuf(lngSizeOf - 1)
      If ReadFile(hStdoutRead, abytReadBuf(0), UBound(abytReadBuf) + 1, lngReadBytes, ByVal 0&) = 0 Then
        subSetError fncRedirectProcess, 19, "ReadFile failed"
        Exit Function
      Else
        'Debug.Print "read-stdout: " & StrConv(abytReadBuf, vbUnicode)
        fncRedirectProcess.strStdOut = fncRedirectProcess.strStdOut & StrConv(abytReadBuf, vbUnicode)
      End If
    End If
 
    If boolSeparateStdoutStderr Then
      lngSizeOf = GetFileSize(hStderrRead, 0&)
      If (lngSizeOf > 0) Then
        ReDim abytReadBuf(lngSizeOf - 1)
        If ReadFile(hStderrRead, abytReadBuf(0), UBound(abytReadBuf) + 1, lngReadBytes, ByVal 0&) = 0 Then
          subSetError fncRedirectProcess, 20, "Read failed"
          Exit Function
        Else
          'Debug.Print "read-stderr: " & StrConv(abytReadBuf, vbUnicode)
          fncRedirectProcess.strStdErr = fncRedirectProcess.strStdErr & StrConv(abytReadBuf, vbUnicode)
        End If
      End If
    End If
 
  Loop Until lngResult = 0
 
 
  Call GetExitCodeProcess(tProcessInfo.hProcess, lngExitCode)
  fncRedirectProcess.lngExitCode = lngExitCode
  fncRedirectProcess.lngErrNumber = 0
  fncRedirectProcess.strErrDescription = ""
 
  'Debug.Print "============="
  'Debug.Print "stdout: " & fncRedirectProcess.strStdOut
  'Debug.Print "stderr: " & fncRedirectProcess.strStdErr
 
  ' not too concerned about reporting error conditions from here on
  CloseHandle tProcessInfo.hThStdoutRead
  CloseHandle tProcessInfo.hProcess
  CloseHandle hStdoutRead
  CloseHandle hStderrRead
  CloseHandle hStdinWrite
 
End Function
 
 
Private Sub subSetError(ByRef rdr As RedirectProcessResult, errNumber As Long, errDescription As String)
  rdr.lngErrNumber = errNumber
  rdr.strErrDescription = errDescription & " (" & Err.LastDllError & ")"
End Sub
clsProcess.vba
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
Option Compare Database
Option Explicit
 
' (c) 2013 randomnoun. All Rights Reserved. This work is licensed under a
' BSD Simplified License. (http://www.randomnoun.com/bsd-simplified.html)
 
' see http://www.randomnoun.com/wp/2013/10/07/its-all-made-out-of-pipes/
' for further documentation for this class
 
 
' event declarations
 
' is triggered when data is read from stdout
Public Event StdoutAvailable(strText As String)
 
' is triggered when data is read from stderr
Public Event StderrAvailable(strText As String)
 
' is triggered after process wait interval
Public Event Tick()
 
 
' Windows structure/constant/functions
 
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
 
Private Type PROCESS_INFORMATION
    hProcess As Long
    hThStdoutRead As Long
    dwProcessId As Long
    dwThStdoutReadId 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 Byte
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type
 
Private Const WAIT_INFINITE         As Long = (-1&)
Private Const STARTF_USESHOWWINDOW  As Long = &H1
Private Const STARTF_USESTDHANDLES  As Long = &H100
Private Const SW_HIDE               As Long = &H0
Private Const SW_NORMAL             As Long = &H1
Private Const HANDLE_FLAG_INHERIT   As Long = &H1
Private Const HANDLE_FLAG_PROTECT_FROM_CLOSE As Long = &H2
Private Const DUPLICATE_SAME_ACCESS         As Long = &H2
Private Const NORMAL_PRIORITY_CLASS As Long = &H20
Private Const CREATE_UNICODE_ENVIRONMENT As Long = &H400
Private Const CREATE_NEW_PROCESS_GROUP As Long = &H200
 
Private Const CSIDL_WINDOWS         As Long = &H24
Private Const MAX_PATH              As Long = 260
Private Const SHGFP_TYPE_CURRENT    As Long = &H0
Private Const SHGFP_TYPE_DEFAULT    As Long = &H1
 
Private Const ERROR_NO_DATA         As Long = 232 ' winerror.h
 
Private Declare Function CreatePipe Lib "kernel32" (phStdoutReadPipe As Long, phStdoutWritePipe As Long, lpPipeAttributes As SECURITY_ATTRIBUTES, ByVal nSize As Long) As Long
Private Declare Function SetHandleInformation Lib "kernel32" (ByVal hObject As Long, ByVal dwMask As Long, ByVal dwFlags 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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
 
Private Declare Function SHGetFolderPath Lib "shfolder" Alias "SHGetFolderPathA" (ByVal hwndOwner As Long, ByVal nFolder As Long, ByVal hToken As Long, ByVal dwFlags As Long, ByVal pszPath As String) As Long
Private Declare Sub GetStartupInfo Lib "kernel32" Alias "GetStartupInfoA" (lpStartupInfo As STARTUPINFO)
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As Long, ByVal lpArguments As String, lpProcessAttributes As Any, lpThStdoutReadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
 
 
' class variables
 
Dim boolSeparateStdoutStderr As Boolean
Dim boolShowWindow As Boolean
Dim strApplicationName As String
Dim strArguments As String
Dim strStdIn As String
Dim strStdOut As String
Dim strStdErr As String
Dim lngExitCode As Long
Dim lngErrNumber As Long
Dim strErrDescription As String
Dim boolIsRunning As Boolean
Dim boolHasRun As Boolean      ' i.e. whether exit codes/numbers in this class are valid
Dim boolTerminate As Boolean   ' set by event handlers to terminate process early
Dim lngStdInBufferPos
 
Dim lngTickWaitMillis As Long
Dim lngTimeoutMillis As Long     ' 0=no timeout
Dim lngTickCount As Long
Dim lngLastOutputTickCount As Long
 
Dim hProcess As Long  ' used to terminate process in class destructor
 
' property getters/setters
 
Public Property Let SeparateStdoutStderr(bSeparateStdoutStderr As Boolean)
  If boolIsRunning Then
    Err.Raise 1, "clsProcess", "Cannot set SeparateStdoutStderr property while process is running"
  End If
  boolSeparateStdoutStderr = bSeparateStdoutStderr
End Property
 
Public Property Get SeparateStdoutStderr() As Boolean
  SeparateStdoutStderr = boolSeparateStdoutStderr
End Property
 
Public Property Let ShowWindow(bShowWindow As Boolean)
  If boolIsRunning Then
    Err.Raise 1, "clsProcess", "Cannot set ShowWindow property while process is running"
  End If
  boolShowWindow = bShowWindow
End Property
 
Public Property Get ShowWindow() As Boolean
  ShowWindow = boolShowWindow
End Property
 
Public Property Let ApplicationName(sApplicationName As String)
  If boolIsRunning Then
    Err.Raise 1, "clsProcess", "Cannot set ApplicationName property while process is running"
  End If
  strApplicationName = sApplicationName
End Property
 
Public Property Get ApplicationName() As String
  ApplicationName = strApplicationName
End Property
 
Public Property Let Arguments(sArguments As String)
  If boolIsRunning Then
    Err.Raise 1, "clsProcess", "Cannot set Arguments property while process is running"
  End If
  strArguments = sArguments
End Property
 
Public Property Get Arguments() As String
  Arguments = strArguments
End Property
 
Public Property Let StdIn(sStdIn As String)
  If boolIsRunning Then
    Err.Raise 1, "clsProcess", "Cannot set StdIn property while process is running; use SendInput instead"
  End If
  strStdIn = sStdIn
End Property
 
Public Property Get StdIn() As String
  StdIn = strStdIn
End Property
 
' stdout/stderr are read-only
Public Property Get StdOut() As String
  StdOut = strStdOut
End Property
 
Public Property Get StdErr() As String
  StdErr = strStdErr
End Property
 
' exit codes/numbers/description are read-only
Public Property Get ExitCode() As Long
  If boolIsRunning Then
    Err.Raise 1, "clsProcess", "Cannot get ExitCode property while process is running"
  ElseIf Not boolHasRun Then
    Err.Raise 1, "clsProcess", "Cannot get ExitCode property before process has been run"
  End If
  ExitCode = lngExitCode
End Property
 
Public Property Get errNumber() As Long
  If boolIsRunning Then
    Err.Raise 1, "clsProcess", "Cannot get ErrNumber property while process is running"
  ElseIf Not boolHasRun Then
    Err.Raise 1, "clsProcess", "Cannot get ErrNumber property before process has been run"
  End If
  errNumber = lngErrNumber
End Property
 
Public Property Get errDescription() As String
  If boolIsRunning Then
    Err.Raise 1, "clsProcess", "Cannot get ErrDescription property while process is running"
  ElseIf Not boolHasRun Then
    Err.Raise 1, "clsProcess", "Cannot get ErrDescription property before process has been run"
  End If
  errDescription = strErrDescription
End Property
 
 
Public Property Get Terminated() As Boolean
  Terminated = boolTerminate
End Property
 
Public Property Get TickCount() As Long
  TickCount = lngTickCount
End Property
 
Public Property Get LastOutputTickCount() As Long
  LastOutputTickCount = lngLastOutputTickCount
End Property
 
' can get/set tick wait millis or tick timeout millis
Public Property Let TickWaitMillis(lTickWaitMillis As Long)
  If boolIsRunning Then
    Err.Raise 1, "clsProcess", "Cannot set TickWaitMillis property while process is running"
  End If
  lngTickWaitMillis = lTickWaitMillis
End Property
 
Public Property Get TickWaitMillis() As Long
  TickWaitMillis = lngTickWaitMillis
End Property
 
Public Property Let TimeoutMillis(lTimeoutMillis As Long)
  'If boolIsRunning Then
  '  Err.Raise 1, "clsProcess", "Cannot set TimeoutMillis property while process is running"
  'End If
  lngTimeoutMillis = lTimeoutMillis
End Property
 
Public Property Get TimeoutMillis() As Long
  TimeoutMillis = lngTimeoutMillis
End Property
 
 
' class methods
 
Private Sub Class_Initialize()
  boolIsRunning = False
  boolHasRun = False
  boolTerminate = False
  lngExitCode = 0
  lngErrNumber = 0
  lngStdInBufferPos = 1 ' next char to send
  strErrDescription = ""
  lngTickWaitMillis = 100
  lngTickCount = 0
  lngLastOutputTickCount = 0
  lngTimeoutMillis = 0
End Sub
 
Private Sub Class_Terminate()
  ' Debug.Print "Class termination"
  If boolIsRunning And (hProcess <> 0) Then
    ' you'd better hope this isn't another process by the time this runs
    Debug.Print "Terminating still-running process"
    TerminateProcess hProcess, -1
    boolIsRunning = False
  End If
End Sub
 
' possibly allow access to boolIsRunning, boolHasRun variables
' in some kind of enumerated state, no doubt
 
' may be called within stdout/stderr event handlers to pass additional data to a process
Public Sub SendInput(strText As String)
  strStdIn = strStdIn & strText
End Sub
 
Public Sub Terminate()
  boolTerminate = True
End Sub
 
 
' same parameters as fncRedirectProcess
' (you can use this method to assist migrating code from fncRedirectProcess to clsProcess)
Public Function ExecuteParams(sApplicationName As String, sArguments As String, _
  Optional sStdIn As String = "", Optional bShowWindow As Boolean = False, _
  Optional bSeparateStdoutStderr As Boolean = False) As RedirectProcessResult
 
  strApplicationName = sApplicationName
  strArguments = sArguments
  strStdIn = sStdIn
  boolShowWindow = bShowWindow
  boolSeparateStdoutStderr = bSeparateStdoutStderr
  Execute
End Function
 
 
Public Sub Execute()
 
  ' TODO: add ACLs to this
  ' TODO: add elements to process environment block
 
  Dim saProcess       As SECURITY_ATTRIBUTES
  Dim saThread        As SECURITY_ATTRIBUTES
  Dim saPipe          As SECURITY_ATTRIBUTES
  Dim tProcessInfo    As PROCESS_INFORMATION
  Dim tStartupInfo    As STARTUPINFO
  Dim hStdoutReadTmp As Long, hStderrReadTmp As Long, hStdinWriteTmp As Long
  Dim hStdoutRead As Long, hStderrRead As Long, hStdinRead As Long
  Dim hStdoutWrite As Long, hStderrWrite As Long, hStdinWrite As Long
  Dim lngReadBytes    As Long
  Dim abytReadBuf()   As Byte
  Dim strWriteBuf     As String
  Dim lngResult, lngResult2 As Long
  Dim strFullArguments  As String
  Dim lngSizeOf       As Long
  Dim strPath         As String
  Dim strEnv          As String
  Dim abytEnv()       As Byte
 
  If boolIsRunning Then
    Err.Raise 1, "clsProcess", "Cannot call Execute while process is running"
  End If
 
  lngExitCode = -1
  lngErrNumber = 0
  strErrDescription = ""
  lngStdInBufferPos = 1
  lngTickCount = 0
  lngLastOutputTickCount = 0
 
  ' input validation
  If (strApplicationName = "") Then subSetError 100, "Missing strApplicationName"
  If (lngErrNumber <> 0) Then Exit Sub
 
  ' assign default security descriptor associated with access token of the calling process.
  saPipe.nLength = Len(saPipe)
  saPipe.bInheritHandle = 1&
  saPipe.lpSecurityDescriptor = 0&
 
  saProcess.nLength = Len(saProcess)
  saProcess.bInheritHandle = 1&
  saProcess.lpSecurityDescriptor = 0&
 
  saThread.nLength = Len(saThread)
  saThread.bInheritHandle = 1&
  saThread.lpSecurityDescriptor = 0&
 
  ' create pipes
 
  ' for stdout (and possibly stderr)
  If (CreatePipe(hStdoutReadTmp, hStdoutWrite, saPipe, 0&) = 0&) Then
    subSetError 1, "CreatePipe failes on tmp stdout"
    Exit Sub
  End If
 
  ' for stderr
  If boolSeparateStdoutStderr Then
    ' separate stdout/stderr pipes
    If (CreatePipe(hStderrReadTmp, hStderrWrite, saPipe, 0&) = 0&) Then
      subSetError 2, "CreatePipe failed on tmp stderr"
      Exit Sub
    End If
  Else
    ' create a duplicate of the stdout handle here for stderr
    ' (in case child decides to close one of them)
    If (DuplicateHandle(GetCurrentProcess(), hStdoutWrite, GetCurrentProcess(), hStderrWrite, 0, True, DUPLICATE_SAME_ACCESS) = 0&) Then
      subSetError 3, "DuplicateHandle failed on stdout/stderr"
      Exit Sub
    End If
  End If
 
  ' for stdin
  If (CreatePipe(hStdinRead, hStdinWriteTmp, saPipe, 0&) = 0&) Then
    subSetError 4, "CreatePipe failed on tmp stdin"
    Exit Sub
  End If
 
  ' duplicate handles: get the "real" handles from the tmp handles, with Properties
  ' set to FALSE. this gives us closeable handles to the pipes.
  ' see http://support.microsoft.com/kb/190351
  If (DuplicateHandle(GetCurrentProcess(), hStdoutReadTmp, GetCurrentProcess(), hStdoutRead, 0, False, DUPLICATE_SAME_ACCESS) = 0&) Then
    subSetError 5, "DuplicateHandle failed on stdout"
    Exit Sub
  End If
 
  If boolSeparateStdoutStderr Then
    If (DuplicateHandle(GetCurrentProcess(), hStderrReadTmp, GetCurrentProcess(), hStderrRead, 0, False, DUPLICATE_SAME_ACCESS) = 0&) Then
      subSetError 6, "DuplicateHandle failed on stderr"
      Exit Sub
    End If
  End If
  If (DuplicateHandle(GetCurrentProcess(), hStdinWriteTmp, GetCurrentProcess(), hStdinWrite, 0, False, DUPLICATE_SAME_ACCESS) = 0&) Then
    subSetError 7, "DuplicateHandle failed on stdin"
    Exit Sub
  End If
 
  ' Close inheritable copies of the handles we do not want to be inherited.
  If (CloseHandle(hStdoutReadTmp) = 0) Then
    subSetError 8, "CloseHandle failed on tmp stdout"
    Exit Sub
  End If
  ' again, probably don't do this if we're using same handle for stdout/err
  If boolSeparateStdoutStderr Then
    If (CloseHandle(hStderrReadTmp) = 0) Then
      subSetError 9, "CloseHandle failed on tmp stderr"
      Exit Sub
    End If
  End If
  If (CloseHandle(hStdinWriteTmp) = 0) Then
    subSetError 10, "CloseHandle failed on tmp stdin"
    Exit Sub
  End If
 
  tStartupInfo.cb = Len(tStartupInfo)
  GetStartupInfo tStartupInfo
  tStartupInfo.cb = Len(tStartupInfo)
  tStartupInfo.hStdOutput = hStdoutWrite
  tStartupInfo.hStdError = hStderrWrite
  tStartupInfo.hStdInput = hStdinRead
  tStartupInfo.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
  tStartupInfo.wShowWindow = IIf(boolShowWindow, SW_NORMAL, SW_HIDE)
 
  ' full command sent to CreateProcess
  strFullArguments = """" & strApplicationName & """" & " " & strArguments
 
  ' define SystemRoot environment variable.
  ' if this isn't here, then TCP network applications will fail with the error
  '   The requested service provider could not be loaded or initialized.
  ' because it can't load mswsock.dll (the path to it contains "%SystemRoot" in the protocol section of the winsock registry)
  ' the other env vars that always seem to be set by CreateProcess (or possibly cmd.exe, which I used for testing) are
  '   "COMSPEC=C:\WINDOWS\system32\cmd.exe" & Chr(0) & _
  '   "PATHEXT=.COM;.EXE;.BAT;.CMD;.VBS;.JS;.WS" & Chr(0) & _
  '   "PROMPT=$P$G" & Chr(0) &
  strPath = String(MAX_PATH, 0)
  If (SHGetFolderPath(0, CSIDL_WINDOWS, 0, SHGFP_TYPE_CURRENT, strPath) <> 0) Then
    subSetError 11, "SHGetFolderPath failed"
    Exit Sub
  End If
  strPath = Left(strPath, InStr(1, strPath, Chr(0)) - 1) ' just up to null terminator
  strEnv = "SystemRoot=" & strPath & Chr(0) & Chr(0)  ' sz terminator + env block terminator
  abytEnv = StrConv(strEnv, vbFromUnicode)            ' encode as byte array
 
  ' if the executable module is a 16-bit application, lpApplicationName should be NULL
  lngResult = CreateProcess(0&, strFullArguments, saProcess, saThread, 1&, _
    NORMAL_PRIORITY_CLASS, abytEnv(0), vbNullString, tStartupInfo, tProcessInfo)
  If (lngResult = 0&) Then
    subSetError 12, "CreateProcess failed"
    Exit Sub
  End If
 
  boolIsRunning = True
  hProcess = tProcessInfo.hProcess
 
  ' XXX: possibly terminate process if errors occur from here on
 
  ' Close pipe handles (do not continue to modify the parent).
  ' We need to make sure that no handles to the write end of the output pipe are maintained
  ' in this process or else the pipe will not close when the child process exits.
  ' Probably not an issue since we don't use a blocking ReadFile later, but this is consistent
  ' with the microsoft kb article above.
  If (CloseHandle(hStdoutWrite) = 0) Then
    subSetError 13, "CloseHandle failed"
    Exit Sub
  End If
  If (CloseHandle(hStdinRead) = 0) Then
    subSetError 14, "CloseHandle failed"
    Exit Sub
  End If
  If (CloseHandle(hStderrWrite) = 0) Then
    subSetError 15, "CloseHandle failed"
    Exit Sub
  End If
 
 
  ' first first stdin block; TODO: may exceed buffer size ?
  If (WriteFile(hStdinWrite, ByVal strStdIn, Len(strStdIn), lngResult, ByVal 0&) = 0) Then
    subSetError 16, "WriteFile failed"
    Exit Sub
  End If
 
  ' Debug.Print "wrote " & lngResult & " bytes to stdin; buflen was " & Len(strStdIn)
  lngStdInBufferPos = lngResult + 1
 
  lngResult = WaitForSingleObject(tProcessInfo.hProcess, lngTickWaitMillis)
  Do
    DoEvents
    Select Case lngResult
      Case 258& ' 500ms timeout
        ' keep on trucking.
        lngResult = WaitForSingleObject(tProcessInfo.hProcess, lngTickWaitMillis)
      Case &H80, &HFFFFFFFF  ' abandoned / failed
        subSetError 17, "Wait abandoned/failed (" & lngResult & ")"
        Exit Sub
      Case 0
        ' wait complete
      Case Else
        subSetError 18, "WaitForSingleObject failed (" & lngResult & ")"
        lngExitCode = -5
        Exit Sub
    End Select
 
    ' pump the i/o stream pipes
    lngSizeOf = GetFileSize(hStdoutRead, 0&)
    If (lngSizeOf > 0) Then
      ReDim abytReadBuf(lngSizeOf - 1)
      If ReadFile(hStdoutRead, abytReadBuf(0), UBound(abytReadBuf) + 1, lngReadBytes, ByVal 0&) = 0 Then
        subSetError 19, "ReadFile failed"
        Exit Sub
      Else
        'Debug.Print "read-stdout: " & StrConv(abytReadBuf, vbUnicode)
        strStdOut = strStdOut & StrConv(abytReadBuf, vbUnicode)
        RaiseEvent StdoutAvailable(StrConv(abytReadBuf, vbUnicode))
        lngLastOutputTickCount = lngTickCount
      End If
    End If
 
    If boolSeparateStdoutStderr Then
      lngSizeOf = GetFileSize(hStderrRead, 0&)
      If (lngSizeOf > 0) Then
        ReDim abytReadBuf(lngSizeOf - 1)
        If ReadFile(hStderrRead, abytReadBuf(0), UBound(abytReadBuf) + 1, lngReadBytes, ByVal 0&) = 0 Then
          subSetError 20, "Read failed"
          Exit Sub
        Else
          'Debug.Print "read-stderr: " & StrConv(abytReadBuf, vbUnicode)
          strStdErr = strStdErr & StrConv(abytReadBuf, vbUnicode)
          RaiseEvent StderrAvailable(StrConv(abytReadBuf, vbUnicode))
          lngLastOutputTickCount = lngTickCount
        End If
      End If
    End If
 
    ' we send input after reading stdout/stderr since those events probably
    ' created the input in the first place
    ' stdStdin had better not change whilst this is executing...
    If Len(strStdIn) >= lngStdInBufferPos Then
      ' Debug.Print "sending '" & Mid(strStdIn, lngStdInBufferPos) & "'"
      strWriteBuf = Mid(strStdIn, lngStdInBufferPos) & Chr(0)
      If (WriteFile(hStdinWrite, ByVal strWriteBuf, Len(strWriteBuf) - 1, lngResult2, ByVal 0&) = 0) Then ' lngresult2==#bytes written
        If Err.LastDllError = ERROR_NO_DATA Then ' Pipe was closed (normal exit path).
          lngResult = 0
        Else
          subSetError 21, "WriteFile failed"
          Exit Sub
        End If
      End If
      lngStdInBufferPos = lngStdInBufferPos + lngResult2
    End If
 
    ' tick events will be at least lngTickWaitMillis apart + time taken to process streams and events above
    RaiseEvent Tick
    lngTickCount = lngTickCount + 1
    If (lngTimeoutMillis > 0) Then
      If ((lngTickCount - lngLastOutputTickCount) * lngTickWaitMillis) > lngTimeoutMillis Then
        boolTerminate = True
      End If
    End If
    If boolTerminate Then
      TerminateProcess tProcessInfo.hProcess, -1
    End If
 
  Loop Until lngResult = 0
 
  Call GetExitCodeProcess(tProcessInfo.hProcess, lngExitCode)
  lngErrNumber = 0
  strErrDescription = ""
  boolIsRunning = False: boolHasRun = True
 
  'Debug.Print "============="
  'Debug.Print "stdout: " & fncRedirectProcess.strStdOut
  'Debug.Print "stderr: " & fncRedirectProcess.strStdErr
 
  ' not too concerned about reporting error conditions from here on
  CloseHandle tProcessInfo.hThStdoutRead
  CloseHandle tProcessInfo.hProcess
  CloseHandle hStdoutRead
  CloseHandle hStderrRead
  CloseHandle hStdinWrite
 
End Sub
 
 
Private Sub subSetError(errNumber As Long, errDescription As String)
  lngErrNumber = errNumber
  strErrDescription = errDescription & " (" & Err.LastDllError & ")"
  boolIsRunning = False: boolHasRun = True
End Sub

And here’s an MSAccess .mdb file which contains both the module and class, plus some tests, and the example form shown earlier.

dbProcess.mdb
dbProcess.mdb

Update 27/10/2013: Added link to a page of system animations.

3 Comments

Leave a Reply to Paul Harrington Cancel reply

Your email address will not be published. Required fields are marked *