Option Explicit

Private Declare Function CreatePipe _
Lib "kernel32" (phReadPipe As Long, _
phWritePipe
As Long, _
lpPipeAttributes
As SECURITY_ATTRIBUTES, _
ByVal nSize As Long) As Long

Private Declare Function
CreateProcess _
Lib "kernel32" _
Alias "CreateProcessA" (ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
lpProcessAttributes
As SECURITY_ATTRIBUTES, _
lpThreadAttributes
As SECURITY_ATTRIBUTES, _
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
TerminateProcess _
Lib "kernel32" (ByVal hProcess As Long, _
ByVal uExitCode 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, _
lpOverlapped
As Any) As Long

Private Declare Function
WriteFile _
Lib "kernel32" (ByVal hFile As Long, _
ByVal lpBuffer As String, _
ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten
As Long, _
lpOverlapped
As Any) As Long

Private Declare Function
GetFileSize _
Lib "kernel32" (ByVal hFile As Long, _
lpFileSizeHigh
As Long) As Long

Private Declare Function
CloseHandle _
Lib "kernel32" (ByVal hObject As Long) As Long

Private Declare Function
GetLastError _
Lib "kernel32" () As Long

Private Declare Sub
CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" (ByVal Destination As String, _
ByVal Source As String, _
ByVal Length As Long)

Private Declare Function lstrLen _
Lib "kernel32" _
Alias "lstrlenA" (ByVal lpString As String) As Long

Private
Type SECURITY_ATTRIBUTES
nLength
As Long
lpSecurityDescriptor As Long
bInheritHandle As
Long
End
Type

Private Type PROCESS_INFORMATION
hProcess
As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
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 Const STARTF_USESTDHANDLES = &H100

Private Const STARTF_USESHOWWINDOW = &H1

Private Const NORMAL_PRIORITY_CLASS = &H20
Dim hReadPipe As Long
Dim
hWritePipe As Long
Dim
hReadFile As Long
Dim
hWriteFile As Long
Dim
pi As PROCESS_INFORMATION

Private Const Pipe_Max_Length As Long = 65536 '64K的空间

Public Function CreateProcessWithPipe(Optional ByVal FileName As String = "cmd.exe") As Boolean
On Error GoTo
ErrHdl
Dim ret&
Dim sa As SECURITY_ATTRIBUTES

With sa
.nLength = Len(sa)
'.bInheritHandle = False
.bInheritHandle = True
.lpSecurityDescriptor = 0
End With

'create two pipe->one for input & output and another for err handle
ret = CreatePipe(hReadPipe, hWriteFile, sa, Pipe_Max_Length): If ret = 0 Then Call RaiseErr
ret = CreatePipe(hReadFile, hWritePipe, sa, Pipe_Max_Length):
If ret = 0 Then Call RaiseErr
'since now , we had create two pipes.
Dim si As STARTUPINFO

'fill start info
With si
.cb = Len(si)
.hStdInput = hReadPipe
.hStdOutput = hWritePipe
.hStdError = hWritePipe
'in fact. both error msg and normal msg r msg, so we can let then in a same handle
.wShowWindow = 0 'hide it
.dwFlags = STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW 'use handles, to make our hstd*** avable. use showwindow, to make our wShowWindow setting avable
End With

'createprocess----normally,it should be cmd.
ret = CreateProcess(vbNullString, FileName, sa, sa, True, NORMAL_PRIORITY_CLASS, 0&, App.Path, si, pi): If ret = 0 Then Call RaiseErr
CreateProcessWithPipe =
True
Exit Function
ErrHdl:
Call TerminateProcessAndClosePipe
CreateProcessWithPipe =
False
End Function

Public Function
GetStringFromPipe() As String
On Error GoTo
ErrHdl
Dim ret&
Dim sBuffer As String
Dim
lRead As Long
Dim
sReturn As String
sBuffer = Space$(Pipe_Max_Length)
ret = ReadFile(hReadFile, sBuffer, Len(sBuffer), lRead,
ByVal 0&) 'lRead is bytes that had read actully
sReturn = Space$(lRead)
CopyMemory sReturn, sBuffer, lRead
GetStringFromPipe = sReturn
>
Exit Function
ErrHdl:
GetStringFromPipe =
""
End Function

Public Function
PipeIsNull() As Boolean
PipeIsNull = (GetFileSize(hReadFile, 0&) <= 0)
End Function

Public Function
PutStringToPipe(ByVal StrToPut As String) As Boolean
On Error GoTo
ErrHdl
'most of time, u need to append a vbCrLf after the string u want to put.
Dim ret&
Dim lWrittenBytes As Long
ret = WriteFile(hWriteFile, StrToPut, lstrLen(StrToPut), lWrittenBytes, ByVal 0&): If ret = 0 Then Call RaiseErr
PutStringToPipe = (lWrittenBytes = Len(StrToPut))
Debug.Print hWriteFile
Exit Function
ErrHdl:
PutStringToPipe =
False
End Function

Public Function
TerminateProcessAndClosePipe() As Boolean
On Error GoTo
ErrHdl
Dim ret&
ret = TerminateProcess(pi.hProcess,
0): If ret = 0 Then Call RaiseErr
ret = CloseHandle(hReadPipe):
If ret = 0 Then Call RaiseErr
ret = CloseHandle(hReadFile):
If ret = 0 Then Call RaiseErr
ret = CloseHandle(hWritePipe):
If ret = 0 Then Call RaiseErr
ret = CloseHandle(hWriteFile):
If ret = 0 Then Call RaiseErr
TerminateProcessAndClosePipe =
True
Exit Function
ErrHdl:
TerminateProcessAndClosePipe =
False
End Function

Private Sub
RaiseErr()
On Error Resume Next
Err.Raise vbObjectError + 1 'raise an error so that to be caught by errhdl
End Sub


 
目前有0条回应
Comment
Trackback
你目前的身份是游客,请输入昵称和电邮!