Option Explicit

Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, 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 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 WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long

Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long

Private Declare Function SetHandleInformation Lib "kernel32" (ByVal hObject As Long, ByVal dwMask As Long, ByVal dwFlags 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

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 Const STARTF_USESTDHANDLES = &H100

Private Const HANDLE_FLAG_INHERIT = 1

Private Const DETACHED_PROCESS = &H8

Private Const PIPE_NOWAIT = &H1

Dim hReadPipe As Long

Dim hWritePipe As Long

Dim hChildReadPipe As Long

Dim hChildWritePipe As Long

Private Sub Form_Load()

    txtCommand.Text = ""

    txtMessage.Text = ""

    txtMessage.Locked = True

    ' 创建管道

    CreatePipe hReadPipe, hWritePipe, ByVal 0, ByVal 0

    CreatePipe hChildReadPipe, hChildWritePipe, ByVal 0, ByVal 0

    SetHandleInformation hWritePipe, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT

    SetHandleInformation hChildReadPipe, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT

    Dim dwMode As Long

    dwMode = PIPE_NOWAIT

    SetNamedPipeHandleState hReadPipe, dwMode, ByVal 0, ByVal 0

    ' 创建CMD进程

    Dim stProcessInfo As PROCESS_INFORMATION

    Dim stStartInfo As STARTUPINFO

    stStartInfo.cb = LenB(stStartInfo)

    stStartInfo.dwFlags = STARTF_USESTDHANDLES

    stStartInfo.hStdError = hWritePipe

    stStartInfo.hStdOutput = hWritePipe

    stStartInfo.hStdInput = hChildReadPipe

    Dim strExe As String

    strExe = "cmd"

    If False = CreateProcess(ByVal vbNullString, ByVal strExe, ByVal 0, ByVal 0, ByVal True, ByVal DETACHED_PROCESS, ByVal 0, ByVal vbNullString, stStartInfo, stProcessInfo) Then

        MsgBox "启动进程失败!"

        Exit Sub

    Else

        CloseHandle stProcessInfo.hThread

        CloseHandle stProcessInfo.hProcess

    End If

    ' 从管道中读出数据, 该数据通常为CMD的版本及版权信息

    ReadFromChildPipe

End Sub

Private Sub Form_Unload(Cancel As Integer)

    CloseHandle hReadPipe

    CloseHandle hWritePipe

    CloseHandle hChildReadPipe

    CloseHandle hChildWritePipe

End Sub

Private Sub txtCommand_KeyPress(KeyAscii As Integer)

    ' 按下回车时将命令写入管道

    If KeyAscii = vbKeyReturn Then

        Dim nWrite As Long

        Dim strBuffer As String

        strBuffer = txtCommand.Text & vbCrLf

        Dim bResult As Boolean

        bResult = WriteFile(ByVal hChildWritePipe, ByVal strBuffer, ByVal Len(strBuffer), nWrite, ByVal 0)

        If bResult = True Then

            ReadFromChildPipe

        Else

            MsgBox "写入失败."

        End If

        txtCommand.Text = ""

    End If

End Sub

Private Sub ReadFromChildPipe()

    ' 读取管道中所有可读取的数据并写入到txtMessage中

    Dim nRead As Long

    Dim strBuffer As String

    Dim nBufferLen As Long

    nRead = -1

    Do While nRead <> 0

        nBufferLen = 65536

        strBuffer = String(nBufferLen, Chr(0))

        Sleep 30

        ReadFile hReadPipe, ByVal strBuffer, ByVal nBufferLen, nRead, ByVal 0

        If nRead <> 0 Then

            strBuffer = Left(strBuffer, nRead)

            txtMessage.Text = txtMessage.Text & strBuffer

            txtMessage.SelStart = Len(txtMessage.Text)

        End If

    Loop

End Sub