Работа с консолью из VB6

Sub main()
    Dim cons As New Console
'    ConsoleWriteLine "Привет пиплы :)"
    cons.ConsoleWriteLine "Echo on"
    cons.ConsoleWriteLine "regsvr32 dllERR.dll"
    Debug.Print cons.ConsoleReadLine
End Sub

Option Explicit
'
'    '© FelixMacintosh (CiberForum.ru)
'    'Интарактивная консоль
'
Private 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 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 WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped 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 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 TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function DuplicateHandle Lib "kernel32" (ByVal hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal hTargetProcessHandle As Long, lpTargetHandle As Long, ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'
Private Const STARTF_USESTDHANDLES As Long = &H100
Private Const STARTF_USESHOWWINDOW As Long = &H1
Private Const DUPLICATE_SAME_ACCESS As Long = &H2
Private Const NORMAL_PRIORITY_CLASS As Long = &H20
 
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle 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 Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessID As Long
    dwThreadId As Long
End Type
Dim lHInput As Long
Dim lHOutput As Long
Dim lCmdID As Long
Dim Out As String '''
Dim WithEvents lab As Label
 
Private Sub Form_Unload(Cancel As Integer)
    StopShell
End Sub
 
Private Sub Form_Activate()
    Dim myHeight&
    Const cnsWidth = 8000
    Const cnsHeight = 6000
    Me.Width = cnsWidth
    Me.Height = cnsHeight
    myHeight& = Me.ScaleHeight - Command1.Height
    Text1.Move 0, 0, Me.ScaleWidth, myHeight&
    Command1.Move 0, myHeight&
End Sub
 
Private Sub SetText(Text$)
    Text1 = Text$: Text1.SelStart = Len(Text)
End Sub
 
Private Sub Form_Load()
    Text1.ForeColor = Text1.BackColor
    Text1.BackColor = 0
    Me.Caption = App.EXEName
    StartShell
    Sleep 200
    GetOutTextShell Out
    Sleep 100
    SetText Out
End Sub
 
Private Sub Form_Resize()
    'Разместить форму по центру
    Me.Move (Screen.Width - Me.ScaleWidth) / 2, (Screen.Height - Me.ScaleHeight) / 2
    
End Sub
 
Private Sub text1_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim CommandLine$, ISR&, lc&
    lc = Len(Text1)
    If KeyCode = 13 And Right$(Text1, 2) = vbCrLf And lc > 2 Then
        CommandLine = Text1
        ISR = InStrRev(CommandLine, ">", lc - 2)
        CommandLine = Mid(CommandLine, IIf(ISR, ISR + 1, 1), lc)
        SendToShell CommandLine
        Sleep 100
        GetOutTextShell Out
        SetText Text1 & Out
    End If
End Sub
 
Private Sub Command1_Click()
    Text1.Text = ""
End Sub
 
Public Sub StopShell()
    If lHInput > 0 Then Call CloseHandle(lHInput)
    If lHOutput > 0 Then Call CloseHandle(lHOutput)
    If lCmdID > 0 Then Call TerminateProcess(lCmdID, ByVal 0&): Call CloseHandle(lCmdID)
End Sub
 
Public Function GetOutTextShell(CommandLine As String) As Boolean
    Dim bBuffer() As Byte
    Dim lLen As Long
    Dim bRes As Boolean
    Dim lLenBuff As Long
    bRes = CBool(PeekNamedPipe(lHOutput, 0&, 0&, 0&, lLen, 0&))
    If Not bRes Then Exit Function
    If lLen <= 0 Then Exit Function
    ReDim bBuffer(lLen)
    If ReadFile(lHOutput, bBuffer(0), lLen, lLenBuff, ByVal 0&) = 0 Then Exit Function
    CommandLine = Left(StrConv(bBuffer, vbUnicode), lLenBuff)
    OemToChar CommandLine, CommandLine
    GetOutTextShell = True
End Function
 
Public Sub SendToShell(CommandLine As String, Optional bNewLine As Boolean)
 
    Dim BytesWritten As Long
    If lHInput = 0 Then Exit Sub
    CharToOem CommandLine, CommandLine
    If bNewLine Then CommandLine = CommandLine & vbNewLine
    If WriteFile(lHInput, ByVal CommandLine, Len(CommandLine), BytesWritten, 0&) = 0 Then
        Exit Sub
    End If
End Sub
 
Public Function StartShell() As Boolean
    On Error GoTo Error
    Dim tSecurityAttributes As SECURITY_ATTRIBUTES
    Dim tStartInfo As STARTUPINFO
    Dim tProcessInfo As PROCESS_INFORMATION
    Dim lCurrentID As Long
    lCurrentID = GetCurrentProcess()
 
    With tStartInfo
        .cb = Len(tStartInfo)
        .dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    End With
 
    With tSecurityAttributes
        .nLength = Len(tSecurityAttributes)
        .bInheritHandle = 1
    End With
 
    If CreatePipe(lHOutput, tStartInfo.hStdOutput, tSecurityAttributes, 0) = 0 Then
        GoTo Error
    End If
 
    If CreatePipe(tStartInfo.hStdInput, lHInput, tSecurityAttributes, 0) = 0 Then
        GoTo Error
    End If
 
    If DuplicateHandle(lCurrentID, tStartInfo.hStdOutput, lCurrentID, tStartInfo.hStdError, _
    0&, True, DUPLICATE_SAME_ACCESS) = 0 Then
        GoTo Error
    End If
 
    If CreateProcess(vbNullString, "cmd", tSecurityAttributes, tSecurityAttributes, 1, NORMAL_PRIORITY_CLASS, _
    ByVal 0&, vbNullString, tStartInfo, tProcessInfo) = 0 Then
        GoTo Error
    End If
 
    With tProcessInfo
        Call CloseHandle(.hThread)
        lCmdID = .hProcess
 
        If .dwProcessID > 0 And .hProcess > 0 Then
            StartShell = True
        Else
            GoTo Error
        End If
    End With
    Exit Function
Error:
    Call StopShell
    StartShell = False
End Function

Option Explicit
'
'    '© FelixMacintosh (CiberForum.ru)
'    'Интерактивная консоль
'
#Const ForDebug = 1 'Режим отладки
 
Private 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 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 WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped 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 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 TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function DuplicateHandle Lib "kernel32" (ByVal hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal hTargetProcessHandle As Long, lpTargetHandle As Long, ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'
Private Const STARTF_USESTDHANDLES As Long = &H100
Private Const STARTF_USESHOWWINDOW As Long = &H1
Private Const DUPLICATE_SAME_ACCESS As Long = &H2
Private Const NORMAL_PRIORITY_CLASS As Long = &H20
 
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle 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 Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type
'Мои переменные
Dim hInput As Long
Dim hOutput As Long
Dim hCmd As Long
Dim sOut As String
Dim nOutLen As Long
Dim bEchoOff As Boolean
Dim bOnlyOut As Boolean
 
Private Sub text1_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim f&, j$(), s$, bRead As Boolean
    
    Dim CommandLine$, ISR&, lc&
    lc = Len(Text1)
    
    If KeyCode = 13 And Right$(Text1, 2) = vbCrLf And lc > 2 Then
        KeyCode = 0
        s = Mid(Text1, nOutLen + 1)
        j = Split(s, vbCrLf)
        bOnlyOut = True 'Только вывод
        For f = 0 To UBound(j) - 1
            If Len(j(f)) Then
                CommandLine = j(f)
                SendToShell CommandLine, True
                SetText
            End If
        Next
    End If
End Sub
 
 
Public Sub SendToShell(ByVal CommandLine As String, Optional bNewLine As Boolean)
 
    Dim BytesWritten As Long
    If hInput = 0 Then Exit Sub
    CommandLine = Trim(CommandLine)
    '
    'Моя интерпритация, для синхронности с консолью....
    'Подрамезуваеться, что синтаксис CMD будет правильным
    '
    If InStr(1, CommandLine, "Echo Off", vbTextCompare) Like "[1-2]" Then
        bEchoOff = True 'Бывает ставят ... @Echo Off
    ElseIf InStr(1, CommandLine, "Echo", vbTextCompare) Like "[1-2]" Then
        bEchoOff = False
    ElseIf InStr(1, CommandLine, "Cls", vbTextCompare) Like "[1-2]" Then
        Command1_Click
    ElseIf InStr(1, CommandLine, "Exit", vbTextCompare) Like "[1-2]" Then
        #If ForDebug Then
            If MsgBox("Введена: " & vbCrLf & "[" & CommandLine & "] ..завершить программу  ?", _
            vbYesNo Or vbInformation) = vbYes Then StopShell: End
        #Else
             Call StopShell: End
        #End If
    End If
    '
    '
    '
    If Not bEchoOff Then CharToOem CommandLine, CommandLine
    If bNewLine Then CommandLine = CommandLine & vbCrLf
    If WriteFile(hInput, ByVal CommandLine, Len(CommandLine), BytesWritten, 0&) = 0 Then
        Exit Sub
    Else
        Call GetOutTextShell(sOut)
    End If
 
End Sub
 
 
Public Function GetOutTextShell(CommandLine As String) As Boolean
    Dim bBuffer() As Byte, f&, inst&
    Dim lLen As Long
    Dim bRes As Boolean
    Dim lLenBuff As Long
    For f = 1 To 100 '100 попыток ...
        DoEvents 'Включить реакцию чтоб не зависла
        Do
            bRes = CBool(PeekNamedPipe(hOutput, 0&, 0&, 0&, lLen, 0&))
            If Not bRes Then Exit Do
            If lLen <= 0 Then Exit Do
            ReDim bBuffer(lLen)
            
            If ReadFile(hOutput, bBuffer(0), lLen, lLenBuff, ByVal 0&) = 0 Then Exit Do
        
            CommandLine = Left(StrConv(bBuffer, vbUnicode), lLenBuff)
            If Not bEchoOff Then OemToChar CommandLine, CommandLine
            
            If bOnlyOut Then
                inst = InStr(1, CommandLine, vbCrLf) + 2
                CommandLine = Mid$(CommandLine, IIf(inst = 2, 1, inst))
            End If
            Exit For
        Loop
        Sleep 100 'Ждать когда появится запись
    Next
    GetOutTextShell = True
End Function
 
Public Sub StopShell()
    While hCmd
        DoEvents 'Включить реакцию
        Call CloseHandle(hInput)
        Call CloseHandle(hOutput)
        hCmd = TerminateProcess(hCmd, ByVal 0&)
        If hCmd Then CloseHandle (hCmd)
        Sleep 100 'Ждать закрытия
    Wend
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    StopShell
End Sub
 
Private Sub Form_Activate()
    Dim myHeight&
    Const cnsWidth = 10000
    Const cnsHeight = 6000
    Me.Width = cnsWidth
    Me.Height = cnsHeight
    myHeight& = Me.ScaleHeight - Command1.Height
    Text1.Move 0, 0, Me.ScaleWidth, myHeight&
    Command1.Move 0, myHeight&
End Sub
 
Private Sub SetText()
    Text1 = Text1 & sOut
    nOutLen = Len(Text1)
    Text1.SelStart = nOutLen
End Sub
 
Private Sub Form_Load()
    Text1.ForeColor = Text1.BackColor
    Text1.BackColor = 0
    Me.Caption = App.EXEName
    StartShell
    SetText
End Sub
 
Private Sub Form_Resize()
    'Разместить форму по центру
    Me.Move (Screen.Width - Me.ScaleWidth) / 2, (Screen.Height - Me.ScaleHeight) / 2
End Sub
 
 
Private Sub Command1_Click()
    sOut = ""
    Text1.Text = ""
    SetText
End Sub
 
Public Function StartShell() As Boolean
    On Error GoTo Error
    Dim tSecurityAttributes As SECURITY_ATTRIBUTES, f&
    Dim tStartInfo As STARTUPINFO
    Dim tProcessInfo As PROCESS_INFORMATION
    Dim lCurrentID As Long
    lCurrentID = GetCurrentProcess()
 
    With tStartInfo
        .cb = Len(tStartInfo)
        .dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    End With
 
    With tSecurityAttributes
        .nLength = Len(tSecurityAttributes)
        .bInheritHandle = 1
    End With
 
    If CreatePipe(hOutput, tStartInfo.hStdOutput, tSecurityAttributes, 0) = 0 Then
        GoTo Error
    End If
 
    If CreatePipe(tStartInfo.hStdInput, hInput, tSecurityAttributes, 0) = 0 Then
        GoTo Error
    End If
 
    If DuplicateHandle(lCurrentID, tStartInfo.hStdOutput, lCurrentID, tStartInfo.hStdError, _
    0&, True, DUPLICATE_SAME_ACCESS) = 0 Then
        GoTo Error
    End If
 
    If CreateProcess(vbNullString, "cmd", tSecurityAttributes, tSecurityAttributes, 1, NORMAL_PRIORITY_CLASS, _
    ByVal 0&, vbNullString, tStartInfo, tProcessInfo) = 0 Then
        GoTo Error
    End If
 
    With tProcessInfo
 
        Call CloseHandle(.hThread)
        hCmd = .hProcess
        If .dwProcessId > 0 And .hProcess > 0 Then
            StartShell = True
            Call GetOutTextShell(sOut) 'Запомнить весь стартовый текст
        Else
            GoTo Error
        End If
    End With
 
    Exit Function
Error:
    Call StopShell
    StartShell = False
End Function