Pipes en Visual Basic 6

qué cabeza tengo... buscando entre mis codes encontré esto

frmMain

Código:

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim WithEvents StdIO As cStdIO
Dim bExitAfterCancel As Boolean

Private Sub cmdCancel_Click()
    If StdIO.Ready = False Then
        AddLog "[" & Time & "] Canceling program.."
        StdIO.Cancel
    Else
        AddLog "[" & Time & "] Try executing a program first ;)"
    End If
End Sub

Private Sub cmdExecute_Click()
    If StdIO.Ready = True Then
        StdIO.CommandLine = txtCommand.Text
        AddLog "[" & Time & "] Executing command:"
        AddLog "-> " & StdIO.CommandLine
        rtbOutput.Text = ""
        StdIO.ExecuteCommand
        'Or simply StdIO.ExecuteCommand txtCommand.Text
    Else
        AddLog "[" & Time & "] Cannot execute command, already in use!"
    End If
End Sub

Private Sub cmdWrite_Click()
    Dim lBytesWritten As Long
    If StdIO.Ready = False Then
        lBytesWritten = StdIO.WriteData(txtWrite.Text)
        If lBytesWritten = -1 Then
            AddLog "[" & Time & "] Failed to write bytes to pipe!"
        Else
            AddLog "[" & Time & "] Successfully wrote " & lBytesWritten & " bytes to pipe!"
        End If
    Else
        AddLog "[" & Time & "] Try executing a program first ;)"
    End If
End Sub

Private Sub Form_Load()
    Set StdIO = New cStdIO
    txtCommand.Text = Environ("ComSpec")
    AddLog "[" & Time & "] Successfully loaded:"
    AddLog "-> " & StdIO.Version
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Cancel = 1
    If StdIO.Ready = True Then
        End
    Else
        bExitAfterCancel = True
        cmdCancel_Click
    End If
End Sub

Private Sub StdIO_CancelFail()
    AddLog "[" & Time & "] Cancel failed to end program. No longer reading pipes."
    DoEvents
    If bExitAfterCancel Then End
End Sub

Private Sub StdIO_CancelSuccess()
    AddLog "[" & Time & "] Cancel success! No longer reading pipes."
    DoEvents
    If bExitAfterCancel Then End
End Sub

Private Sub StdIO_Complete()
    AddLog "[" & Time & "] Complete!"
End Sub

Private Sub StdIO_Error(ByVal Number As Integer, ByVal Description As String)
    AddLog "[" & Time & "] Error #" & Number & ": " & Description
End Sub

Private Sub StdIO_GotData(ByVal Data As String)
    AddOutput Data
End Sub

Private Sub AddLog(ByVal strData As String)
    rtbLog.Text = rtbLog.Text & strData & vbNewLine
    rtbLog.SelStart = Len(rtbLog.Text) - 2 'Cause of vbNewLine
End Sub

Private Sub AddOutput(ByVal strData As String)
    rtbOutput.Text = rtbOutput.Text & strData
    rtbOutput.SelStart = Len(rtbOutput.Text)
End Sub

cKillProcess

Código:

Option Explicit

'The following are just global constant for the class itself
Const c_Version = "Kill Process Class v0.1 BETA by Amine Haddad"

'The following are just declarations (also known as API Calls)
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)

'The following are just constants and types declared for this class only
Private Const WM_CLOSE As Long = &H10
Private Const WM_DESTROY As Long = &H2
Private Const WM_ENDSESSION = &H16
Private Const PROCESS_TERMINATE As Long = &H1
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5

Private Type OSVERSIONINFO
    OSVSize As Long
    dwVerMajor As Long
    dwVerMinor As Long
    dwBuildNumber As Long
    PlatformID As Long
    szCSDVersion As String * 128
End Type

'The following are types to determine the settings of this class
Private Type t_Settings
    Init As Boolean
    Is9X As Boolean
End Type

Dim Settings As t_Settings

'The following is to allow the user to get the version of this class
Public Property Get Version() As String
    'The version of this class.
    Version = c_Version
End Property


'The following are the functions used in this class
Public Function KillProcess(ByVal lProcessID As Long) As Boolean
    Dim lHandle As Long
    
    If Not Settings.Init Then Call InitializeClass
    If ClosePID(lProcessID) = True Then
        If Settings.Is9X Then
            lHandle = OpenProcess(PROCESS_TERMINATE, False, lProcessID)
            If lHandle = 0 Then
                KillProcess = False
            Else
                KillProcess = CBool(TerminateProcess(lHandle, 0&))
                CloseHandle lHandle
            End If
        Else
            KillProcess = True
        End If
    Else
        KillProcess = False
    End If
End Function

Private Sub InitializeClass()
    'This function needs to be ran before running any other functions.
    'We NEED to know if we are in Windows 9x or not.
    Dim OsInfo As OSVERSIONINFO

    With OsInfo
        .OSVSize = Len(OsInfo)
        .szCSDVersion = Space(128)
        
        Call GetVersionEx(OsInfo)
        'After this line, we will know if the system is 9X or else.
        Settings.Is9X = (.PlatformID = VER_PLATFORM_WIN32_WINDOWS) And (.dwVerMajor > 4) Or (.dwVerMajor = 4 And .dwVerMinor > 0) Or (.PlatformID = VER_PLATFORM_WIN32_WINDOWS And .dwVerMajor = 4 And .dwVerMinor = 0)
    End With

    'We have successfully initialized this class.
    Settings.Init = True
End Sub

Private Function ClosePID(ByVal lProcessID As Long) As Boolean
    'This function here will go through all windows and kill the pid that it was given
    Dim hWndChild As Long
    Dim lThreadProcessID As Long
    
    hWndChild = GetWindow(GetDesktopWindow(), GW_CHILD)

    Do While (hWndChild <> 0)
        If (GetParent(hWndChild) = 0) Then
            Call GetWindowThreadProcessId(hWndChild, lThreadProcessID)
            If (lProcessID = lThreadProcessID) Then
                Call PostMessage(hWndChild, IIf(Settings.Is9X, WM_ENDSESSION, WM_CLOSE), IIf(Settings.Is9X, True, False), 0&)
                ClosePID = True
            End If
        End If
        
        hWndChild = GetWindow(hWndChild, GW_HWNDNEXT)
    Loop
End Function

Public Function PIDInUse(ByVal lProcessID As Long) As Boolean
    'This function will return true if the PID is in use.
    Dim hWndChild As Long
    Dim lThreadProcessID As Long
    
    hWndChild = GetWindow(GetDesktopWindow(), GW_CHILD)

    Do While (hWndChild <> 0)
        If (GetParent(hWndChild) = 0) Then
            Call GetWindowThreadProcessId(hWndChild, lThreadProcessID)
            If (lProcessID = lThreadProcessID) Then
                PIDInUse = True
                Exit Function
            End If
        End If
        
        hWndChild = GetWindow(hWndChild, GW_HWNDNEXT)
        DoEvents
    Loop
End Function

cStdIO

Código:

Option Explicit

'The following are just global constant for the class itself
Const c_Version = "Standard Input/Output Class v0.1 BETA by Amine Haddad"

'The following are declarations of API calls
Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize As Long) As Long
Private Declare Function SetNamedPipeHandleState Lib "kernel32" (ByVal hNamedPipe As Long, lpMode As Long, lpMaxCollectionCount As Long, lpCollectDataTimeout 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
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hHandle As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'The following are types used by API calls listed above
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

'The following are constants needed (but not all used) by API calls above
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESTDHANDLES = &H100&
Private Const STARTF_USESHOWWINDOW = &H1
Private Const SW_HIDE = 0
Private Const PIPE_WAIT = &H0
Private Const PIPE_NOWAIT = &H1
Private Const PIPE_READMODE_BYTE = &H0
Private Const PIPE_READMODE_MESSAGE = &H2
Private Const PIPE_TYPE_BYTE = &H0
Private Const PIPE_TYPE_MESSAGE = &H4

'The following are variables required throughout the program
Private mCommand    As String   'The command to process
Private mOutput     As String   'The final output of the whole program
Private mCancel     As Boolean  'Set this to True to cancel
Private mReady      As Boolean  'Are we ready to launch new command?

'The following are variables required throughbout the program's functions
Dim lRetVal         As Long                 'RETurn VALue of a certain function.
Dim hReadPipe       As Long                 'Read Pipe handle created by CreatePipe
Dim hWritePipe      As Long                 'Write Pite handle created by CreatePipe
Dim lBytesRead      As Long                 'Amount of byte read from the Read Pipe handle
Dim sBuffer         As String * 4096        'String buffer reading the Pipe
Dim hReadPipe2      As Long                 'Read Pipe handle created by CreatePipe
Dim hWritePipe2     As Long                 'Write Pite handle created by CreatePipe

'The following are events to be launched throughout the program
Public Event GotData(ByVal Data As String)
Public Event CancelSuccess()
Public Event CancelFail()
Public Event Complete()
Public Event Error(ByVal Number As Integer, ByVal Description As String)

'Definitions of error messages throughout the program (passed in the Error event):
'Error #400: Not ready to process another command.
'Error #401: Command Line empty.
'Error #402: Not processing a command to cancel.
'Error #403: Not ready to change settings.
'Error #404: CreatePipe failed.
'Error #405: SetNamedPipeHandleState failed.
'Error #406: CreateProcess failed.

'The following are properties that can be used to keep track of what we are doing
Public Property Let CommandLine(ByVal Command As String)
    'This allows us to set the new command line to process.
    If mReady = True Then
        mCommand = Command
    Else
        RaiseEvent Error(402, "Not ready to change settings.")
    End If
End Property

Public Property Get CommandLine() As String
    'This allows us to read the current command line setting.
    CommandLine = mCommand
End Property

Public Property Get Ready() As Boolean
    'This allows us to read the state of the program.
    'Will return True if it is ready to process another command.
    Ready = mReady
End Property

Public Property Get Version() As String
    'The version of this class.
    Version = c_Version
End Property

'The following are events initialized by the class
Private Sub Class_Initialize()
    'Once class started, we can't possibly already have a command running,
    'so we will set the ready variable to true so we can process another.
    mReady = True
End Sub

'The following are subs and functions used in the program.
Public Sub Cancel()
    'If called, and under condition a program is being processed, it will
    'interrupt and end the program.
    If mReady = False Then
        mCancel = True
    Else
        RaiseEvent Error(402, "Not processing a command to cancel.")
    End If
End Sub

Public Function ExecuteCommand(Optional CommandLine As String) As String
    'This is it. The function that will actually do the work. It is not hard,
    'read through the comments to understand.
    Dim tStartup        As STARTUPINFO          'Self explanatory..
    Dim tProc           As PROCESS_INFORMATION  'Self explanatory..
    Dim tSecAttr        As SECURITY_ATTRIBUTES  'Self explanatory..
    
    'Let's check if we are ready to process this command.
    If mReady = False Then
        'We are not. Warn the user and exit the function.
        RaiseEvent Error(400, "Not ready to process another command.")
        Exit Function
    End If
    
    'We are ready, let's tell it that we are not ready so we don't get another command
    'while processing the current one. Also set mCancel to false, we don't want to
    'cancel something before we start it do we ;)
    mReady = False
    mCancel = False
    
    'If the parameter we got is not empty, then let's overwrite the current mCommand value.
    If Len(CommandLine) > 0 Then
        mCommand = CommandLine
    End If
    
    'If we still have a empty command line (mCommand) then let's just tell the user and
    'exit the function.
    If Len(mCommand) = 0 Then
        mReady = True 'We put mReady before RaiseEvent because user might launch another command on the
        'error event. If we put it after, it would tell him not ready, but now it will tell him it is ready.
        RaiseEvent Error(401, "Command Line empty.")
        Exit Function
    End If
    
    'Let's set the Security Attributes that we will pass on
    tSecAttr.nLength = LenB(tSecAttr)
    tSecAttr.bInheritHandle = True
    tSecAttr.lpSecurityDescriptor = False
    
    'Now, we will create the output pipe. lRetVal will return 0 if it failed.
    lRetVal = CreatePipe(hReadPipe, hWritePipe, tSecAttr, 0&)
    
    'Let's check if it succeeded or failed.
    If lRetVal = 0 Then
        'If an error occur during the Pipe creation exit
        mReady = True
        RaiseEvent Error(404, "CreatePipe failed.")
        Exit Function
    End If
    
    'Do the input pipe
    lRetVal = CreatePipe(hReadPipe2, hWritePipe2, tSecAttr, 0&)
    If lRetVal = 0 Then
        'If an error occur during the Pipe creation exit
        mReady = True
        RaiseEvent Error(404, "CreatePipe failed.")
        Exit Function
    End If
    
    'The next step is to set it to non-blocking mode meaning that it will instantly
    'return when ReadFile is called (you will understand later).
    lRetVal = SetNamedPipeHandleState(hReadPipe, PIPE_READMODE_BYTE Or PIPE_NOWAIT, 0&, 0&)
    
    If lRetVal <> 0 Then
        'Well, we failed. Let's exit.
        '(NOTICE: You don't have to exit, but since this is to show how to make it
        '         non-blocking only then I will set it to exit when it fails.)
        mReady = True
        RaiseEvent Error(405, "SetNamedPipeHandleState failed.")
        Exit Function
    End If

    'Let's set the StartupInfo for the command line when it is launched
    tStartup.cb = LenB(tStartup)
    tStartup.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    tStartup.wShowWindow = SW_HIDE      'We want window to not show up so we use SW_HIDE.
    tStartup.hStdOutput = hWritePipe    'Set the StdOut and StdError output
    tStartup.hStdError = hWritePipe     'to the same Write Pipe handle.
    tStartup.hStdInput = hReadPipe2
    
    'Let's launch the program.
    lRetVal = CreateProcessA(0&, mCommand, tSecAttr, tSecAttr, _
        1&, NORMAL_PRIORITY_CLASS, 0&, 0&, tStartup, tProc)
        
    'Let's check if it succeeded.
    If lRetVal <> 1 Then
        'Unfortunatly, we failed. Maybe it can't find CMD.EXE?
        mReady = True
        RaiseEvent Error(406, "CreateProcess failed.")
        Exit Function
    End If
    
    'Now we will clear the mOutput variable
    mOutput = ""
    
    'Okay, from this point on we might need assistance from cKillProcess
    'So let's bring in KP ;)
    Dim KP As New cKillProcess
    
    'Now that all is set, let's start getting the output from the ReadPipe handle
    Do
        DoEvents                                'Let's not hog cpu
        If mCancel = True Then Exit Do          'If we need to cancel, exit do.
        Sleep 30                                'Just for smooth sailing.
        lRetVal = ReadFile(hReadPipe, sBuffer, 4096, lBytesRead, 0&)
        If lRetVal <> 0 Then
            'We got data!
            'Let's add it to mOutput (all data since begining)
            mOutput = mOutput & Left(sBuffer, lBytesRead)
            'And finally we will send data to the GotData event.
            RaiseEvent GotData(Left(sBuffer, lBytesRead))
            'Let's just not hog cpu again :P
            DoEvents
        End If
        'And loop until we don't see the process anymore :)
    Loop While KP.PIDInUse(tProc.dwProcessId)
    
    'Now we're done so close the opened handles
    Call CloseHandle(tProc.hProcess)
    Call CloseHandle(tProc.hThread)
    Call CloseHandle(hReadPipe)
    Call CloseHandle(hReadPipe2)
    Call CloseHandle(hWritePipe)
    Call CloseHandle(hWritePipe2)
    
    'Return the Outputs property with the entire DOS output
    ExecuteCommand = mOutput
    
    'Set it so we are ready to launch another command
    mReady = True
    
    'And finally, check if we ended with a cancel.
    'If we did, then end the process and call the event respectivly.
    'If we didn't, then call Complete.
    If mCancel Then
        If KP.KillProcess(tProc.dwProcessId) Then
            Set KP = Nothing
            RaiseEvent CancelSuccess
        Else
            Set KP = Nothing
            RaiseEvent CancelFail
        End If
    Else
        Set KP = Nothing
        RaiseEvent Complete
    End If
    
    'And we're done ;)
End Function

Public Function WriteData(ByVal strData As String) As Long
    'This function will return -1 if it failed to write to pipe,
    'otherwise, it will return the bytes written.
    Dim lBytesWritten As Long
    Dim arrByte() As Byte
    arrByte() = StrConv(strData & vbCrLf & Chr(0), vbFromUnicode)
    lRetVal = WriteFile(hWritePipe2, arrByte(0), UBound(arrByte), lBytesWritten, 0&)
    WriteData = IIf(lRetVal = 0, -1, lBytesWritten - 2)
    'Ok, in the line that just passed I did lBytesWritten - 3 because we added a vbCrLf (2 bytes) and a Chr(0) (1 byte)
    'and let's not forget its base 0 so 3 is really 0-1-2 so 2.
    'I didn't want those included because if the user sends 'hello' and it said
    'sent 8 bytes then he would just be wondering what happened. This will fix that problem.
End Function

date cuenta que los dos ultimos son modulos de clase