1Attribute VB_Name = "Process"
2' From Microsoft Knowledge Base Article - Q129796 and 173085
3'
4'
5
6Public Type ProcessOutput
7    ret As Long             'return value
8    out As String           'whatever was printed to stdout
9    err As String           'whatever was printed to stderr
10End Type
11
12Public Type ProcessContext
13    outHnd As Long          'handler for the redirected output
14    outName As String       'name of the file to which output is redirected
15End Type
16
17Private Type STARTUPINFO
18    cb As Long
19    lpReserved As String
20    lpDesktop As String
21    lpTitle As String
22    dwX As Long
23    dwY As Long
24    dwXSize As Long
25    dwYSize As Long
26    dwXCountChars As Long
27    dwYCountChars As Long
28    dwFillAttribute As Long
29    dwFlags As Long
30    wShowWindow As Integer
31    cbReserved2 As Integer
32    lpReserved2 As Long
33    hStdInput As Long
34    hStdOutput As Long
35    hStdError As Long
36End Type
37
38Private Type PROCESS_INFORMATION
39    hProcess As Long
40    hThread As Long
41    dwProcessID As Long
42    dwThreadID As Long
43End Type
44
45Private Type SECURITY_ATTRIBUTES
46          nLength As Long
47          lpSecurityDescriptor As Long
48          bInheritHandle As Long
49End Type
50
51Public Type OVERLAPPED
52        Internal As Long
53        InternalHigh As Long
54        offset As Long
55        OffsetHigh As Long
56        hEvent As Long
57End Type
58
59Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
60                    hHandle As Long, ByVal dwMilliseconds As Long) As Long
61
62Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
63                    lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
64                    lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
65                    ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
66                    ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
67                    lpStartupInfo As STARTUPINFO, lpProcessInformation As _
68                    PROCESS_INFORMATION) As Long
69
70Private Declare Function CloseHandle Lib "kernel32" _
71                  (ByVal hObject As Long) As Long
72
73Private Declare Function GetExitCodeProcess Lib "kernel32" _
74                    (ByVal hProcess As Long, lpExitCode As Long) As Long
75
76Private Declare Function CreatePipe Lib "kernel32" _
77                    (phReadPipe As Long, phWritePipe As Long, _
78                     lpPipeAttributes As Any, ByVal nSize As Long) As Long
79
80Public Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
81                    (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
82                     ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, _
83                     ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
84                     ByVal hTemplateFile As Long) As Long
85
86Public Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" _
87                    (ByVal lpFileName As String) As Long
88
89Private Declare Function ReadFile Lib "kernel32" _
90                    (ByVal hFile As Long, ByVal lpBuffer As String, _
91                     ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, _
92                     ByVal lpOverlapped As Any) As Long
93
94Public Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" _
95                    (ByVal lpszPath As String, ByVal lpPrefixString As String, _
96                     ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
97
98Public Declare Function GetFileSize Lib "kernel32" _
99                    (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
100
101Public Declare Function SetFilePointer Lib "kernel32" _
102                    (ByVal hFile As Long, ByVal lDistanceToMove As Long, _
103                     lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
104
105
106
107Private Const NORMAL_PRIORITY_CLASS = &H20&
108Private Const STARTF_USESTDHANDLES = &H100&
109Private Const INFINITE = -1&
110
111Public Const GENERIC_WRITE = &H40000000
112Public Const GENERIC_READ = &H80000000
113
114Public Const FILE_SHARE_READ = &H1
115Public Const FILE_SHARE_WRITE = &H2
116Public Const FILE_SHARE_DELETE = &H4
117
118Public Const CREATE_ALWAYS = 2
119
120Public Const INVALID_HANDLE_VALUE = -1
121
122Public Const FILE_FLAG_DELETE_ON_CLOSE = &H4000000
123Public Const FILE_FLAG_OVERLAPPED = &H40000000
124
125Public Const FILE_ATTRIBUTE_NORMAL = &H80
126Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
127
128Public Const FILE_BEGIN = 0
129
130Public Const MAX_PATH = 260
131
132'my own constants
133Private Const STDOUT_PIPE = 1
134Private Const STDOUT_IN_PIPE = 2
135Private Const STDERR_PIPE = 3
136Private Const STDERR_IN_PIPE = 4
137
138Private Const READ_BUFF_SIZE = 256
139
140
141'
142' Pending issue here: waiting for the called process is infinite
143' The output is intercepted only if doWait and doOutput are set to true
144'
145Public Function ExecCmd(cmdline$, doWait As Boolean, doOutput As Boolean) As ProcessOutput
146    Dim ret As Long
147    Dim res As ProcessOutput
148    Dim ctx As ProcessContext
149    '
150    Dim proc As PROCESS_INFORMATION
151    Dim start As STARTUPINFO
152    '
153    Dim doPipes As Boolean
154    '
155    Dim cnt As Long, atpt As Long
156    Dim buff As String * READ_BUFF_SIZE
157
158    doPipes = (doWait = True) And (doOutput = True)
159    ctx.outName = String(MAX_PATH, Chr$(0))
160
161    ' Initialize the STARTUPINFO structure:
162    start.cb = Len(start)
163
164    If doPipes Then
165        OpenContext ctx, True
166        start.dwFlags = STARTF_USESTDHANDLES
167        start.hStdError = ctx.outHnd
168    End If
169
170    ' Start the shelled application:
171    ret& = CreateProcessA(vbNullString, cmdline$, 0&, 0&, 1&, _
172         NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)
173
174    If ret <> 1 Then
175        CloseContext ctx, False
176        err.Raise 12001, , "CreateProcess failed. Error: " & err.LastDllError
177    End If
178
179    ' Wait for the shelled application to finish:
180    If doWait = True Then
181        ret& = WaitForSingleObject(proc.hProcess, INFINITE)
182        Call GetExitCodeProcess(proc.hProcess, res.ret&)
183
184        Call CloseHandle(proc.hThread)
185        Call CloseHandle(proc.hProcess)
186
187        'read the dump of the stderr, non-blocking
188        If doPipes Then
189            ret& = GetFileSize(ctx.outHnd, 0)
190            'we consider that not being able to read the stderr log is not a fatal error
191            If ret <> -1 Then
192                ret = SetFilePointer(ctx.outHnd, 0, 0, FILE_BEGIN)
193                If ret = 0 Then
194                    Do
195                        ret = ReadFile(ctx.outHnd, buff, READ_BUFF_SIZE, cnt, 0&)
196                        res.err = res.err & Left$(buff, cnt)
197                    Loop While ret <> 0 And cnt <> 0
198                Else
199                    MsgBox "SetFilePointer failed. Error: " & err.LastDllError & " " & err.Description
200                End If
201            Else
202                MsgBox "GetFileSize failed. Error: " & err.LastDllError & " " & err.Description
203            End If
204
205            CloseContext ctx, False
206        End If
207
208    End If
209
210    ExecCmd = res
211End Function
212
213Private Sub OpenContext(ByRef Context As ProcessContext, doError As Boolean)
214
215    Dim sa As SECURITY_ATTRIBUTES
216    Dim msg As String
217
218    ' Initialize the SECURITY_ATRIBUTES info
219    sa.nLength = Len(sa)
220    sa.bInheritHandle = 1&
221    sa.lpSecurityDescriptor = 0&
222
223    ret& = GetTempFileName(".", "err", 0, Context.outName)
224    If ret = 0 Then
225        msg = "GetTempFileName failed for stderr. Error: " & err.LastDllError
226        If doError = True Then
227            err.Raise 12000, , msg
228        Else
229            MsgBox msg
230        End If
231    End If
232
233    Context.outHnd = CreateFile(Context.outName, _
234                                GENERIC_WRITE Or GENERIC_READ, _
235                                FILE_SHARE_WRITE Or FILE_SHARE_READ Or FILE_SHARE_DELETE, _
236                                sa, CREATE_ALWAYS, _
237                                FILE_ATTRIBUTE_TEMPORARY, _
238                                FILE_FLAG_DELETE_ON_CLOSE)
239
240    If Context.outHnd = INVALID_HANDLE_VALUE Then
241        msg = "CreateFile failed for stderr. Error: " & err.LastDllError
242        If doError = True Then
243            err.Raise 12000, , msg
244        Else
245            MsgBox msg
246        End If
247    End If
248
249End Sub
250
251Private Sub CloseContext(ByRef Context As ProcessContext, doError As Boolean)
252    Dim msg As String
253    If Context.outHnd <> 0 Then
254        CloseHandle Context.outHnd
255    End If
256    If Not IsNull(Context.outName) Then
257        'delete the file
258        ret = DeleteFile(Context.outName)
259        If ret = 0 Then
260            msg = "DeleteFile failed. Error: " & err.LastDllError & Chr(13) & _
261                        "You have a temporary file at " & pathBuff
262            If doError = True Then
263                err.Raise 12000, , msg
264            Else
265                MsgBox msg
266            End If
267        End If
268    End If
269End Sub
270
271Private Sub ClosePipes(ByRef Pipes() As Long, Size As Integer)
272    Dim i As Integer
273    For i = 0 To Size
274        ClosePipe Pipes, i
275    Next i
276End Sub
277
278Private Sub ClosePipe(ByRef Pipes() As Long, Pos As Integer)
279
280    If Pipes(Pos) <> 0 Then
281        CloseHandle Pipes(Pos)
282        Pipes(Pos) = 0
283    End If
284End Sub
285
286