Option Explicit

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 GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function ExitProcess Lib "kernel32" (ByVal uExitCode As Long)
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode 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 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 CreateProcessA Lib "kernel32" (ByVal _
        lpApplicationName As Long, ByVal lpCommandLine As _
        String, lpProcessAttributes As Any, lpThreadAttributes _
        As Any, ByVal bInheritHandles As Long, ByVal _
        dwCreationFlags As Long, ByVal lpEnvironment As Long, _
        ByVal lpCurrentDirectory As Long, lpStartupInfo As Any, _
        lpProcessInformation As Any) As Long

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

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 WaitForSingleObject Lib "kernel32" ( _
        ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
        
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

Private Const INFINITE = &HFFFF
Private Const DUPLICATE_SAME_ACCESS = &H2
         
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESTDHANDLES = &H100&
Private Const STARTF_USESHOWWINDOW = &H1
      
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
            
            
Dim bExit As Boolean
'

Private Sub Command1_Click()
Dim s As String

    If Len(Trim$(Me.Text2.Text)) >  0  Then
        Screen.MousePointer =  11 
        bExit = False
        Me.Command2.Enabled = True
        s = ExecCmd(Me.Text2.Text, Me.Text1)
        Me.Text1.SelStart = Len(Me.Text1.Text)
        Me.Text1.SelText = s
        Me.Command2.Enabled = False
        Screen.MousePointer =  0 
    End If
    
End Sub

Private Function ExecCmd(ByVal cmdline As String, ByRef OUT As VB.TextBox) As String
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim sa As SECURITY_ATTRIBUTES
Dim L As Long, Result As Long, bSuccess As Long
Dim Buffer As String
Dim s As String
Dim sss As String
Dim hReadPipe As Long, hWritePipe As Long
Dim hReadStdOutputDup As Long
Dim hReadStdError As Long
Dim hWriteStdError As Long
Dim hReadStdErrorDup As Long

    OUT.Text = ""
    
    sa.nLength = Len(sa)
    sa.bInheritHandle =  1 &
    sa.lpSecurityDescriptor =  0 &
    
    start.cb = Len(start)
    start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    
    Result = CreatePipe(hReadPipe, hWritePipe, sa,  0 )
    If Result =  0  Then
        ExecCmd = "ERROR: CreatePipe failed Error!"
        GoTo lb_out
    End If
    If DuplicateHandle(GetCurrentProcess(), hReadPipe, GetCurrentProcess(), hReadStdOutputDup,  0 &,  0 &, DUPLICATE_SAME_ACCESS) =  0  Then
        ExecCmd = "ERROR: " & Err.LastDllError & " DuplicateHandle ReadPipe."
        GoTo lb_out
    End If
    start.hStdOutput = hWritePipe
    
    If CreatePipe(hReadStdError, hWriteStdError, sa,  0 ) =  0  Then
        ExecCmd = "ERROR: " & Err.LastDllError & " CreatePipe StdError."
        GoTo lb_out
    End If
    If DuplicateHandle(GetCurrentProcess(), hReadStdError, GetCurrentProcess(), hReadStdErrorDup,  0 &,  0 &, DUPLICATE_SAME_ACCESS) =  0  Then
        ExecCmd = "ERROR: " & Err.LastDllError & " DuplicateHandle ReadStdError."
        GoTo lb_out
    End If
    start.hStdError = hWriteStdError
    
    
    Result = CreateProcessA( 0 &, cmdline, sa, sa,  1 &, _
        NORMAL_PRIORITY_CLASS,  0 &,  0 &, start, proc)

    If Result <>  0  Then
        
        Dim lPeekData As Long
        
        Do
            Call PeekNamedPipe(hReadStdOutputDup, ByVal  0 &,  0 &, ByVal  0 &, _
                lPeekData, ByVal  0 &)
            
            If lPeekData >  0  Then
                Buffer = Space$(lPeekData)
                bSuccess = ReadFile(hReadStdOutputDup, Buffer, Len(Buffer), L,  0 &)
                
                If bSuccess =  1  Then
                    
                    s = Left(Buffer, L)
                    sss = Space$(Len(s))
                    OemToChar s, sss
                    
                    OUT.SelStart = Len(OUT.Text)
                    OUT.SelText = sss
                    
                Else
                    ExecCmd = "ERROR: ReadFile failed!"
                    Exit Do
                End If
            Else
                bSuccess = WaitForSingleObject(proc.hProcess,  0 &)
                        
                If bSuccess =  0  Then
                    Exit Do
                End If
            End If
            
            Call PeekNamedPipe(hReadStdErrorDup, ByVal  0 &,  0 &, ByVal  0 &, _
                lPeekData, ByVal  0 &)
            
            If lPeekData >  0  Then
                Buffer = Space$(lPeekData)
                bSuccess = ReadFile(hReadStdErrorDup, Buffer, Len(Buffer), L,  0 &)
                
                If bSuccess =  1  Then
                    
                    s = Left(Buffer, L)
                    sss = Space$(Len(s))
                    OemToChar s, sss
                    
                    OUT.SelStart = Len(OUT.Text)
                    OUT.SelText = sss
                    
                Else
                    ExecCmd = "ERROR: ReadFile failed!"
                    Exit Do
                End If
            Else
                bSuccess = WaitForSingleObject(proc.hProcess,  0 &)
                        
                If bSuccess =  0  Then
                    Exit Do
                End If
            End If
        
            
            If bExit Then
                bExit = False
                TerminateProcess proc.hProcess, Result
                ExecCmd = vbCrLf & "Stopped."
                GoTo lb_out
            End If
            
            DoEvents
        Loop
        ExecCmd = vbCrLf & "Success."
            
    Else
        ExecCmd = "ERROR: Error while starting process!"
    End If
    
lb_out:
    Call CloseHandle(proc.hProcess)
    Call CloseHandle(proc.hThread)
    Call CloseHandle(hReadPipe)
    Call CloseHandle(hWritePipe)
    Call CloseHandle(hReadStdError)
    Call CloseHandle(hWriteStdError)
    Call CloseHandle(hReadStdOutputDup)
    Call CloseHandle(hReadStdErrorDup)
    
    
End Function

Private Sub Command2_Click()
    bExit = True
    Me.Command1.Enabled = True
    Me.Command2.Enabled = False
    Screen.MousePointer =  0 
End Sub

Private Sub Form_Load()
    Command1.Caption = "Start"
    Me.Command2.Enabled = False
End Sub