Option Explicit
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
Declare Function PeekNamedPipe Lib "kernel32" ( _
ByVal hNamedPipe As Long, _
lpBuffer As Any, _
ByVal nBufferSize As Long, _
lpBytesRead As Long, _
lpTotalBytesAvail As Long, _
lpBytesLeftThisMessage As Long _
) As Long
Private Declare Function GetExitCodeProcess Lib _
"kernel32" (ByVal hProcess As Long, lpExitCode _
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
Private Type PIPE
hReadPipe As Long
hWritePipe As Long
End Type
Private Const CREATE_NEW_CONSOLE = &H10
Public Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESHOWWINDOW = &H1
Private Const STARTF_USESIZE = &H2
Private Const STARTF_USEPOSITION = &H4
Private Const STARTF_USECOUNTCHARS = &H8
Private Const STARTF_USEFILLATTRIBUTE = &H10
Private Const STARTF_RUNFULLSCREEN = &H20
Private Const STARTF_FORCEONFEEDBACK = &H40
Private Const STARTF_FORCEOFFFEEDBACK = &H80
Private Const STARTF_USESTDHANDLES = &H100
'Window settings flags
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_NORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_MAXIMIZE = 3
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 6
Private Const SW_SHOWMINNOACTIVE = 7
'This displays the new window, but keeps the current window active
Private Const SW_SHOWNA = 8
Private Const SW_RESTORE = 9
'This passes on the settings from the SW_flags
Private Const SW_SHOWDEFAULT = 10
Private Const SW_MAX = 10
Private Const INVALID_HANDLE_VALUE = -1
Private Const STILL_ACTIVE = &H103&
'This function runs cmdLine$ and returns the stdout/err from that program
'The function does not end until cmdLine$ has closed
'The biggest problem with the original function was that if the shelled program did NOT
'write anything to stdout/err, the function would freeze up at
'bSuccess = ReadFile(hReadPipe, mybuff, 1024, bytesread, 0&)
'This rewrite of the code fixes that, and waits for the app to close before returning anything
Public Function ExecCmd(cmdLine$) As String
Dim proc As PROCESS_INFORMATION, ret As Long, bSuccess As Long, pID As Long
Dim start As STARTUPINFO
Dim sa As SECURITY_ATTRIBUTES, hReadPipe As Long, hWritePipe As Long
Dim bytesread As Long, mybuff As String
Dim intBytesToRead As Long
Dim Result As Long
Dim tBytesA As Long, tBytesR As Long, tMsg As Long, Bytes As Long
Dim ExitCode As Long
'4kb should be enough to read most things
intBytesToRead = 4096
mybuff = String(CInt(intBytesToRead), Chr$(65))
sa.nLength = Len(sa)
sa.bInheritHandle = 1&
sa.lpSecurityDescriptor = 0&
'Create the pipe
ret = CreatePipe(hReadPipe, hWritePipe, sa, 0)
'If creating a pipe failed, we fail the function
If ret = 0 Then
ExecCmd = Null
Exit Function
End If
start.cb = Len(start)
'Any combination of the STARTF_ flags can be used here by writing
'start.dwFlags = STARTF_1 + STARTF_2...etc
start.dwFlags = STARTF_USESHOWWINDOW + STARTF_USESTDHANDLES 'Hidden the window
'start.dwFlags = STARTF_USESTDHANDLES 'Visible window
start.hStdOutput = hWritePipe
start.hStdError = hWritePipe
'The SW_ flags are only used if STARTF_USESHOWWINDOW is set above
start.wShowWindow = SW_HIDE
' Start the shelled application:
ret& = CreateProcessA(0&, cmdLine$, sa, sa, 1&, _
NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
Do
'Check to see if the app closed
GetExitCodeProcess proc.hProcess, ExitCode
'Check to see if there is any unread stuff in the pipe
'This check is nessasary, other the ReadFile function will hang if there is nothing in the pipe
Result = PeekNamedPipe(hReadPipe, ByVal 0&, 0, tBytesR, tBytesA, tMsg)
'If so, read it
If Result <> 0 And tBytesA > 0 Then
bSuccess = ReadFile(hReadPipe, mybuff, intBytesToRead, bytesread, 0&)
ExecCmd = ExecCmd & Left(mybuff, tBytesA)
End If
'This is needed to reduce overhead, otherwise our app will hang until this function ends
DoEvents
'Don't quit looping until the app has closed
Loop While ExitCode = STILL_ACTIVE
'Close everything down, if still running
ret& = CloseHandle(proc.hProcess)
ret& = CloseHandle(proc.hThread)
ret& = CloseHandle(hReadPipe)
ret& = CloseHandle(hWritePipe)
End Function
Reply With Quote