Attribute VB_Name = "Process"
' From Microsoft Knowledge Base Article - Q129796 and 173085
'
'
Public Type ProcessOutput
ret As Long 'return value
out As String 'whatever was printed to stdout
err As String 'whatever was printed to stderr
End Type
Public Type ProcessContext
outHnd As Long 'handler for the redirected output
outName As String 'name of the file to which output is redirected
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
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
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Public Type OVERLAPPED
Internal As Long
InternalHigh As Long
offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode 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
Public Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, _
ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Public Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" _
(ByVal lpFileName As String) 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
Public Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" _
(ByVal lpszPath As String, ByVal lpPrefixString As String, _
ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Public Declare Function GetFileSize Lib "kernel32" _
(ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Public Declare Function SetFilePointer Lib "kernel32" _
(ByVal hFile As Long, ByVal lDistanceToMove As Long, _
lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESTDHANDLES = &H100&
Private Const INFINITE = -1&
Public Const GENERIC_WRITE = &H40000000
Public Const GENERIC_READ = &H80000000
Public Const FILE_SHARE_READ = &H1
Public Const FILE_SHARE_WRITE = &H2
Public Const FILE_SHARE_DELETE = &H4
Public Const CREATE_ALWAYS = 2
Public Const INVALID_HANDLE_VALUE = -1
Public Const FILE_FLAG_DELETE_ON_CLOSE = &H4000000
Public Const FILE_FLAG_OVERLAPPED = &H40000000
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
Public Const FILE_BEGIN = 0
Public Const MAX_PATH = 260
'my own constants
Private Const STDOUT_PIPE = 1
Private Const STDOUT_IN_PIPE = 2
Private Const STDERR_PIPE = 3
Private Const STDERR_IN_PIPE = 4
Private Const READ_BUFF_SIZE = 256
'
' Pending issue here: waiting for the called process is infinite
' The output is intercepted only if doWait and doOutput are set to true
'
Public Function ExecCmd(cmdline$, doWait As Boolean, doOutput As Boolean) As ProcessOutput
Dim ret As Long
Dim res As ProcessOutput
Dim ctx As ProcessContext
'
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
'
Dim doPipes As Boolean
'
Dim cnt As Long, atpt As Long
Dim buff As String * READ_BUFF_SIZE
doPipes = (doWait = True) And (doOutput = True)
ctx.outName = String(MAX_PATH, Chr$(0))
' Initialize the STARTUPINFO structure:
start.cb = Len(start)
If doPipes Then
OpenContext ctx, True
start.dwFlags = STARTF_USESTDHANDLES
start.hStdError = ctx.outHnd
End If
' Start the shelled application:
ret& = CreateProcessA(vbNullString, cmdline$, 0&, 0&, 1&, _
NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)
If ret <> 1 Then
CloseContext ctx, False
err.Raise 12001, , "CreateProcess failed. Error: " & err.LastDllError
End If
' Wait for the shelled application to finish:
If doWait = True Then
ret& = WaitForSingleObject(proc.hProcess, INFINITE)
Call GetExitCodeProcess(proc.hProcess, res.ret&)
Call CloseHandle(proc.hThread)
Call CloseHandle(proc.hProcess)
'read the dump of the stderr, non-blocking
If doPipes Then
ret& = GetFileSize(ctx.outHnd, 0)
'we consider that not being able to read the stderr log is not a fatal error
If ret <> -1 Then
ret = SetFilePointer(ctx.outHnd, 0, 0, FILE_BEGIN)
If ret = 0 Then
Do
ret = ReadFile(ctx.outHnd, buff, READ_BUFF_SIZE, cnt, 0&)
res.err = res.err & Left$(buff, cnt)
Loop While ret <> 0 And cnt <> 0
Else
MsgBox "SetFilePointer failed. Error: " & err.LastDllError & " " & err.Description
End If
Else
MsgBox "GetFileSize failed. Error: " & err.LastDllError & " " & err.Description
End If
CloseContext ctx, False
End If
End If
ExecCmd = res
End Function
Private Sub OpenContext(ByRef Context As ProcessContext, doError As Boolean)
Dim sa As SECURITY_ATTRIBUTES
Dim msg As String
' Initialize the SECURITY_ATRIBUTES info
sa.nLength = Len(sa)
sa.bInheritHandle = 1&
sa.lpSecurityDescriptor = 0&
ret& = GetTempFileName(".", "err", 0, Context.outName)
If ret = 0 Then
msg = "GetTempFileName failed for stderr. Error: " & err.LastDllError
If doError = True Then
err.Raise 12000, , msg
Else
MsgBox msg
End If
End If
Context.outHnd = CreateFile(Context.outName, _
GENERIC_WRITE Or GENERIC_READ, _
FILE_SHARE_WRITE Or FILE_SHARE_READ Or FILE_SHARE_DELETE, _
sa, CREATE_ALWAYS, _
FILE_ATTRIBUTE_TEMPORARY, _
FILE_FLAG_DELETE_ON_CLOSE)
If Context.outHnd = INVALID_HANDLE_VALUE Then
msg = "CreateFile failed for stderr. Error: " & err.LastDllError
If doError = True Then
err.Raise 12000, , msg
Else
MsgBox msg
End If
End If
End Sub
Private Sub CloseContext(ByRef Context As ProcessContext, doError As Boolean)
Dim msg As String
If Context.outHnd <> 0 Then
CloseHandle Context.outHnd
End If
If Not IsNull(Context.outName) Then
'delete the file
ret = DeleteFile(Context.outName)
If ret = 0 Then
msg = "DeleteFile failed. Error: " & err.LastDllError & Chr(13) & _
"You have a temporary file at " & pathBuff
If doError = True Then
err.Raise 12000, , msg
Else
MsgBox msg
End If
End If
End If
End Sub
Private Sub ClosePipes(ByRef Pipes() As Long, Size As Integer)
Dim i As Integer
For i = 0 To Size
ClosePipe Pipes, i
Next i
End Sub
Private Sub ClosePipe(ByRef Pipes() As Long, Pos As Integer)
If Pipes(Pos) <> 0 Then
CloseHandle Pipes(Pos)
Pipes(Pos) = 0
End If
End Sub