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