cls_PipeAccess.cls

'
'========================================C O D E   S T A R T   H E R E========================================
'=============================================代    码    开    始=============================================
'
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
'
'=========================================C O D E    E N D    H E R E=========================================
'=============================================代    码    结    束=============================================

[本日志由 JiaJia 于 2007-09-26 07:00 PM 编辑]
文章来自: 炉子
引用通告: 查看所有引用 | 我要引用此文章
Tags: