重定义控制台程序的输入输出

unit RedCon;

(*

simple yet working console i/o redirection

(c) 2002 bhoc@pentagroup.ch

freeware

there are two Data events (OnStdOut and OnStdErr) that return a string;

two other events just signal that the program is running or that it has ended.

the SendData() method will submit a string to an open application such as cmd.exe.

sample:

procedure TForm1.Button1Click(Sender: TObject);

begin

 fCon := TRedirectedConsole.Create(Edit1.Text);

 fCon.OnStdOut := OnConStdOut;

 fCon.OnStdErr := OnConStdErr;

 fCon.OnRun := OnConRun;

 fCon.OnEnd := OnConEnd;

 fCon.Run;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

 fCon.Free;

end;

procedure TForm1.OnConStdOut(Sender: TObject; s: String);

begin

 memo1.Lines.Append(s);

end;

procedure TForm1.OnConStdErr(Sender: TObject; s: String);

begin

 memo2.Lines.Append(s);

end;

procedure TForm1.OnConRun(Sender: TOBject);

begin

 Application.ProcessMessages;

 Sleep(10);

end;

procedure TForm1.OnConEnd(Sender: TOBject);

begin

 MessageBox(Application.Handle, 'Program has ended', 'Program Ended', MB_OK or MB_ICONINFORMATION or MB_SETFOREGROUND);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

 fCon.SendData(edit2.Text + #13#10);

end;

*)

interface

uses windows;

type

 TOnData = procedure(Sender: TObject; Data: String) of object;

 TOnRun = procedure(Sender: TObject) of object;

 TRedirectedConsole = Class(TObject)

 private

   fStdInRead, fStdInWrite: THandle;

   fStdOutRead, fStdOutWrite: THandle;

   fStdErrRead, fStdErrWrite: THandle;

   fSA: TSecurityAttributes;

   fPI: TProcessInformation;

   fSI: TStartupInfo;

   fCmdLine: String;

   fOnStdOut, fOnStdErr: TOnData;

   fOnRun, fOnEnd: TOnRun;

   fIsRunning: Boolean;

   fHidden: boolean;

   fTerminate: boolean;

   function ReadHandle(h: THandle; var s: string): integer;

 protected

 public

   constructor Create(CommandLine: String);

   destructor Destroy; override;

   procedure Run;

   procedure SendData(s: String);

   property OnStdOut: TOnData read fOnStdOut write fOnStdOut;

   property OnStdErr: TOnData read fOnStdErr write fOnStdErr;

   property OnRun: TOnRun read fOnRun write fOnRun;

   property OnEnd: TOnRun read fOnEnd write fOnEnd;

   property IsRunning: boolean read fIsRunning;

   property HideWindow: boolean read fHidden write fHidden;

 end;

implementation

const BufSize = 1024;

constructor TRedirectedConsole.Create(CommandLine: String);

begin

 inherited Create;

 fCmdLine := CommandLine;

 fIsRunning := False;

 fHidden := True;

 FillChar(fSA, SizeOf(fSA), 0);

 fSA.nLength := SizeOf(fSA);

 fSA.lpSecurityDescriptor := nil;

 fSA.bInheritHandle := True;

 CreatePipe(fStdInRead, fStdInWrite, @fSA, BufSize);

 CreatePipe(fStdOutRead, fStdOutWrite, @fSA, BufSize);

 CreatePipe(fStdErrRead, fStdErrWrite, @fSA, BufSize);

end;

destructor TRedirectedConsole.Destroy;

begin

 if fIsRunning then

 begin

   fTerminate := True;

 end;

 CloseHandle(fStdInWrite);

 CloseHandle(fStdOutRead);

 CloseHandle(fStdErrRead);

 inherited;

end;

function TRedirectedConsole.ReadHandle(h: THandle; var s: String): integer;

var

 BytesWaiting: Cardinal;

 Buf: Array[1..BufSize] of char;

{$IFDEF VER100}

 BytesRead: Integer;

{$ELSE}

 BytesRead: Cardinal;

{$ENDIF}

begin

 Result := 0;

 PeekNamedPipe(h, nil, 0, nil, @BytesWaiting, nil);

 if BytesWaiting > 0 then

 begin

   if BytesWaiting > BufSize then

     BytesWaiting := BufSize;

   ReadFile(h, Buf[1], BytesWaiting, BytesRead, nil);

   s := Copy(Buf, 1, BytesRead);

   Result := BytesRead;

 end;

end;

procedure TRedirectedConsole.SendData(s: String);

var

{$IFDEF VER100}

 BytesWritten: Integer;

{$ELSE}

 BytesWritten: Cardinal;

{$ENDIF}

begin

 if fIsRunning then

 begin

   WriteFile(fStdInWrite, s[1], Length(s), BytesWritten, nil);

 end;

end;

procedure TRedirectedConsole.Run;

var

 s: String;

begin

 fTerminate := False;

 FillChar(fSI, SizeOf(fSI), 0);

 fSI.cb := SizeOf(fSI);

 if fHidden then

   fSI.wShowWindow := SW_HIDE

 else

   fSI.wShowWindow := SW_SHOWDEFAULT;

 fSI.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;

 fSI.hStdInput := fStdInRead;

 fSI.hStdOutput := fStdOutWrite;

 fSI.hStdError := fStdErrWrite;

 if CreateProcess(nil, PChar(fCmdLine), nil, nil, True, NORMAL_PRIORITY_CLASS, nil, nil, fSI, fPI) then

 begin

   fIsRunning := True;

   CloseHandle(fStdOutWrite);

   CloseHandle(fStdErrWrite);

   CloseHandle(fStdInRead);

   CloseHandle(fPI.hThread);

   While WaitForSingleObject(fPI.hProcess, 10) = WAIT_TIMEOUT do

   begin

     if fTerminate then

     begin

       TerminateProcess(fPi.hProcess, 0);

     end;

     if ReadHandle(fStdOutRead, s) > 0 then

       if Assigned(fOnStdOut) then

         fOnStdOut(Self, s);

     if ReadHandle(fStdErrRead, s) > 0 then

       if Assigned(fOnStdErr) then

         fOnStdErr(Self, s);

     if Assigned(fOnRun) then

       fOnRun(Self);

   end;

   if ReadHandle(fStdOutRead, s) > 0 then

     if Assigned(fOnStdOut) then

       fOnStdOut(Self, s);

   if ReadHandle(fStdErrRead, s) > 0 then

     if Assigned(fOnStdErr) then

       fOnStdErr(Self, s);

   CloseHandle(fPI.hProcess);

   fIsRunning := False;

   if Assigned(fOnEnd) then

     fOnEnd(Self);

 end;

end;

end.