【Delphi】一个可以不断执行命令、能读取命令输出而且隐藏的Console类[更新：允许实时输出]

               

unit uConsole;

interface

uses
{$IF CompilerVersion <= 22}
  Classes, Windows, Messages, SysUtils,
  Variants, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ComCtrls, SyncObjs;
{$ELSE}
  System.Classes, Winapi.Windows, Winapi.Messages, System.SysUtils,
  System.Variants, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.ComCtrls, System.SyncObjs;
{$ENDIF}

type
  IConsole = interface
    function ExecCmd(aCmd: String; aPersist: TPersistent = nil;
                      aWaitFinished: Boolean = False): Boolean;
  end;

  TiConsole = class
    class function Create: IConsole;
  end; // aStrings可以是TStringList, TMemo.Lines, TRichEdit.Lines, TListBox.Items等

implementation

type
  TConsoleThread = class;

  TConsole = class(TInterfacedObject, IConsole) // cmd控制台
  private
    IsLine: Boolean;
    Strings: TStrings;
    ErrorExists: Boolean;
    WaitFinished: Boolean;
    FinishEvent: TSimpleEvent;
    ConsoleThread: TConsoleThread;
    ProcessInfo: TProcessInformation;
    ErrorPipeRead, ErrorPipeWrite: THandle;
    InputPipeRead, InputPipeWrite: THandle;
    OutputPipeRead, OutputPipeWrite: THandle;
    procedure WritePipe(aPipe: THandle; Cmd: String);
  public
    constructor Create;
    destructor Destroy; override;
    function ExecCmd(aCmd: String; aPersist: TPersistent; aWaitFinished: Boolean): Boolean;
  end;

  TConsoleThread = class(TThread) // Cmd控制台输入输出监控线程
  private
    Console: TConsole;
    IsTerminated: Boolean;
    TextBuf: array of AnsiChar;
    function ReadPipe(aPipe: THandle): String;
  private
    procedure AddString(const aOutputStr, aErrorStr: String);
    function IsLastLine(const aOutputStr: String): Boolean;
  protected
    procedure Execute; override;
  public
    constructor Create(aConsole: TConsole);
  end;

class function TiConsole.Create: IConsole;
begin
  Result := TConsole.Create;
end;

constructor TConsole.Create;
var
  CmdApp: String;
  CmdSize: Integer;
  Start: TStartUpInfo;
  Security: TSecurityAttributes;
begin
  inherited Create;

  // 取Cmd控制台的COMSPEC环境变量的路径
  SetLength(CmdApp, 255);
  CmdSize := GetEnvironmentVariable('COMSPEC', @CmdApp[1], 255);
  SetLength(CmdApp, CmdSize);

  // 建立管道
  with Security do
  begin
    nLength := SizeOf(TSecurityAttributes);
    bInheritHandle := True;
    lpSecurityDescriptor := nil;
  end;
  CreatePipe(InputPipeRead , InputPipeWrite , @Security, 0);
  CreatePipe(OutputPipeRead, OutputPipeWrite, @Security, 0);
  CreatePipe(ErrorPipeRead , ErrorPipeWrite , @Security, 0);

  // 启动一个隐藏的、输入输出被重定向的Cmd控制台
  FillChar(Start, SizeOf(Start), #0);
  Start.cb := SizeOf(Start);
  Start.hStdInput := InputPipeRead;
  Start.hStdOutput := OutputPipeWrite;
  Start.hStdError := ErrorPipeWrite;
  Start.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;
  Start.wShowWindow := SW_HIDE;
  CreateProcess(nil, PChar(CmdApp), @Security, @Security, True,
    CREATE_NEW_CONSOLE or SYNCHRONIZE, nil, nil, Start, ProcessInfo);

  FinishEvent := TSimpleEvent.Create; // 生成简单同步事件
  FinishEvent.ResetEvent;

  ConsoleThread := TConsoleThread.Create(Self); // 生成线程、并自动启动
  while FinishEvent.WaitFor(20) = wrTimeout do // 等待cmd控制台准备完毕
    Application.ProcessMessages;
end;

destructor TConsole.Destroy;
begin
  ConsoleThread.Terminate;
  WritePipe(InputPipeWrite, 'EXIT'); // 关闭Cmd控制台
  CloseHandle(ProcessInfo.hProcess);
  CloseHandle(ProcessInfo.hThread );
  CloseHandle(InputPipeRead  );
  CloseHandle(InputPipeWrite );
  CloseHandle(OutputPipeRead );
  CloseHandle(OutputPipeWrite);
  CloseHandle(ErrorPipeRead  );
  CloseHandle(ErrorPipeWrite );
  FinishEvent.Free;
  inherited Destroy;
end;

function TConsole.ExecCmd(aCmd: String; aPersist: TPersistent; aWaitFinished: Boolean): Boolean;
begin
  Result := False;
  if (UpperCase(Trim(aCmd)) = 'EXIT') then Exit;

  if aPersist is TMemo then
  begin
    Strings := TMemo(aPersist).Lines;
    IsLine := True;
  end
  else if aPersist is TRichEdit then
  begin
    Strings := TRichEdit(aPersist).Lines;
    IsLine := True;
  end
  else if aPersist is TListBox then
  begin
    Strings := TListBox(aPersist).Items;
    IsLine := False;
  end
  else if aPersist is TStringList then
  begin
    Strings := TStringList(aPersist);
    IsLine := False;
  end
  else if aPersist is TStrings then
  begin
    Strings := TStrings(aPersist);
    IsLine := False;
  end
  else
  begin
    Strings := nil;
    IsLine := False;
  end;
  WaitFinished := aWaitFinished;
  if not (Strings is TStringList) then
    WaitFinished := True;
  if Strings <> nil then Strings.Clear;
  
  ErrorExists := False;
  FinishEvent.ResetEvent;
  WritePipe(InputPipeWrite, aCmd); // 运行命令CmdStr
  if WaitFinished and (Strings is TStringList) then
    FinishEvent.WaitFor(INFINITE) // 阻塞式
  else
  begin
    while FinishEvent.WaitFor(10) = wrTimeout do
      Application.ProcessMessages;
  end;

  if not ErrorExists then  Result := True;
end;

procedure TConsole.WritePipe(aPipe: THandle; Cmd: String);
var // 将命令写入到输入管道
  BytesWritten: DWord;
  AnsiBuf: AnsiString;
begin
  // 命令字符串是Ansi字符串，Cmd输入需要回车符CR/LF；
  AnsiBuf := AnsiString(Cmd + #13#10);
  WriteFile(aPipe, AnsiBuf[1], Length(AnsiBuf), BytesWritten, nil);
end;

// -------------------------读屏幕输出的线程-------------------------------------

constructor TConsoleThread.Create(aConsole: TConsole);
begin
  Console := aConsole;
  IsTerminated := True;
  SetLength(TextBuf, 32767);
  inherited Create(False); // 生成线程、并自动启动线程
  FreeOnTerminate := True; // 线程结束后自动释放线程对象
  Priority := tpHigher;
end;

procedure TConsoleThread.Execute;
{ 监视Cmd控制台的输出：每10毫秒读出一次错误管道和输出管道的信息 }
var
  ErrorStr, OutputStr: String;
begin
  while not Terminated do
  begin
    // 读入错误管道和正常管道的信息.
    ErrorStr  := ReadPipe(Console.ErrorPipeRead );
    OutputStr := ReadPipe(Console.OutputPipeRead);
    if (ErrorStr  <> '') then Console.ErrorExists := True;
    if (OutputStr <> '') or (ErrorStr <> '') then
    begin
      AddString(OutputStr, ErrorStr);
      if IsLastLine(OutputStr) then
      begin // 控制台命令运行结束后，最后一行显示的都是类似于C:\folder>的字符串
        Console.FinishEvent.SetEvent; // 设置Cmd控制台命令运行完毕的事件
      end;
    end
    else
      Sleep(10); // 每10毫秒读一次
  end;
end;

function TConsoleThread.ReadPipe(aPipe: THandle): String;
// 通过管道读取Cmd控制台的输出，BytesRemain为未读的字节数
var
  AnsiRst: AnsiString;
  BytesRead: LongWord;
  PipeSize, BytesRemain, ByteCount: Cardinal;
begin
  Result := '';
  ByteCount := 0;
  PipeSize := Length(TextBuf);
  // 检查管道是否有东西可读
  PeekNamedPipe(aPipe, nil, PipeSize, @BytesRead, @PipeSize, @BytesRemain);
  if BytesRead > 0 then
  begin
    ReadFile(aPipe, TextBuf[ByteCount], PipeSize, BytesRead, nil);
    AnsiRst := AnsiString(TextBuf); // TextBuffer内含的是AnsiString字符串
    SetLength(AnsiRst, BytesRead);
    Result := String(AnsiRst);
  end;
end;

procedure TConsoleThread.AddString(const aOutputStr, aErrorStr: String);
var
  Str, StrItem: String;
  Count, P, Len: Integer;
begin
  if not assigned(Console.Strings) then
    Exit;

  Str := aOutputStr;
  Count := Console.Strings.Count;
  if Count = 0 then
  begin
    IsTerminated := True;
    P := Pos(#13#10, Str) + 2;
    if P > 0 then Str := Copy(Str, P, Str.Length);
  end;
  Str :=  aErrorStr + Str;
  if Console.IsLine then
  begin // 非TStringList
    if (Count > 0) and (not IsTerminated) then
      Console.Strings[Count - 1] := Console.Strings[Count - 1] + Str
    else
      Console.Strings.Add(Str);
  end
  else
  begin // TStringList
    if not IsTerminated then
      Str := Console.Strings[Count - 1] + Str;
    Len := Length(Str);
    repeat
      P := Pos(#13#10, Str);
      if P < 1 then
      begin
        StrItem := Str;
        Str := '';
      end
      else
      begin
        StrItem := Copy(Str, 1, P - 1);
        Str := Copy(Str, P + 2, Len);
      end;
      if not IsTerminated then
      begin
        Console.Strings[Count - 1] := StrItem;
        IsTerminated := True;
      end
      else
        Console.Strings.Add(StrItem);
    until (Str = '');
  end;
  IsTerminated := (aOutputStr[Count] = #13) and (aOutputStr[Count - 1] = #10);
end;

function TConsoleThread.IsLastLine(const aOutputStr: String): Boolean;
var
  LastStr: String;
  I, Len, BeginPos: Integer;
begin
  Result := False;
  BeginPos := 0;
  for I := Length(aOutputStr) - 1 downto 1 do
  begin
    if (aOutputStr[I] = #13) and (aOutputStr[I + 1] = #10) then
    begin
      BeginPos := I + 2;
      Break;
    end;
  end;
  if (BeginPos = 0) then
    LastStr := aOutputStr
  else
    LastStr := Copy(aOutputStr, BeginPos, Length(aOutputStr) - BeginPos + 1);

  Len := Length(LastStr);
  if (Len >= 4) and (LastStr[1] >= 'A') and (LastStr[1] <= 'Z') and
    (LastStr[2] = ':') and (LastStr[3] = '\') and (LastStr[Len] = '>') then
  begin
    Result := True;
  end;
end;

end.

============================================== 示例 ============================================

unit uMain;

interface

uses
{$IF CompilerVersion <= 22}
  Windows, Messages, SysUtils, Variants,
  Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, uConsole;
{$ELSE}
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Vcl.StdCtrls, uConsole, Vcl.ComCtrls;
{$ENDIF}

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    Label3: TLabel;
    Edit2: TEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    List: TStringList;
    LastSender: TObject;
    Console1, Console2: IConsole;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormShow(Sender: TObject);
begin
  List := TStringList.Create;
  Button1.OnClick := Button1Click;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if (LastSender <> Sender) then
  begin
    LastSender := Sender;
  end;
  if not assigned(Console1) then
    Console1 := TiConsole.Create;
  Console1.ExecCmd(Edit1.Text, Memo1, False);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if (LastSender <> Sender) then
  begin
    LastSender := Sender;
  end;
  if not assigned(Console2) then
    Console2 := TiConsole.Create;
  Console2.ExecCmd(Edit2.Text, List, True);
  Memo1.Lines.Text := List.Text;
end;

end.

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 636
  ClientWidth = 842
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnShow = FormShow
  DesignSize = (
    842
    636)
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 12
    Top = 4
    Width = 24
    Height = 13
    Caption = #21629#20196
  end
  object Label2: TLabel
    Left = 8
    Top = 102
    Width = 24
    Height = 13
    Caption = #36755#20986
  end
  object Label3: TLabel
    Left = 14
    Top = 52
    Width = 24
    Height = 13
    Caption = #21629#20196
  end
  object Edit1: TEdit
    Left = 13
    Top = 20
    Width = 726
    Height = 21
    Anchors = [akLeft, akTop, akRight]
    TabOrder = 0
    Text = 'Ping 114.114.114.114'
  end
  object Memo1: TMemo
    Left = 8
    Top = 121
    Width = 826
    Height = 507
    Anchors = [akLeft, akTop, akRight, akBottom]
    Font.Charset = GB2312_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'Tahoma'
    Font.Style = []
    ParentFont = False
    ScrollBars = ssVertical
    TabOrder = 1
  end
  object Button1: TButton
    Left = 754
    Top = 17
    Width = 75
    Height = 25
    Anchors = [akTop, akRight]
    Caption = #25191#34892'1'
    TabOrder = 2
    OnClick = Button1Click
  end
  object Button2: TButton
    Left = 754
    Top = 66
    Width = 75
    Height = 25
    Anchors = [akTop, akRight]
    Caption = #25191#34892'2'
    TabOrder = 3
    OnClick = Button2Click
  end
  object Edit2: TEdit
    Left = 13
    Top = 69
    Width = 727
    Height = 21
    Anchors = [akLeft, akTop, akRight]
    TabOrder = 4
    Text = 'dir C:\Windows\Fonts'
  end
end