捐赠 | 广告 | 注册 | 发布 | 上传 | 关于我们    
  沪ICP备05001939号 DELPHI盒子 | 盒子论坛 | 盒子文章 | 盒子问答悬赏 | 最新更新 | 论坛检索 | 下载中心 | 高级搜索    
  精品专区 | 繁體中文 | 奖励公告栏 | 直通车账号登陆 | 关闭GOOGLE广告 | 临时留言    
 
广告
评论:StdIORedirect执行dos命令的控件(无下载)
hujiacheng 39335 2009/12/30 15:07:55
demos失效。。郁闷呢。。呵呵。
zhahongyi 38958 2009/11/3 12:46:33
{ *==========*
  |   StdIORedirect
  |
  |   Component   to   get   output   from   and   provide   input   to   command   line   apps
  |
  |   Copyright   (C)   Colin   Wilson   1999.     All   rights   reserved
  |
  |   Public   methods   and   properties:
  |
  |   procedure   Run   (fileName,   cmdLine,   directory   :   string);
  |
  |       Run   a   program   with   redirected   output
  |
  |   procedure   AddInputText   (const   st   :   string);
  |
  |       Add   a   line   of   text   to   be   sent   to   the   application's   STDIN
  |
  |   procedure   Terminate;
  |
  |       Terminate   the   program   started   with   'Run'
  |
  |   property   ReturnValue   :   DWORD   read   fReturnValue;
  property   OutputText   :   TStrings   read   fOutputText;
  property   ErrorText   :   TStrings   read   fErrorText;
  property   Running   :   boolean   read   fRunning;


  published
  property   OnOutputText   :   TOnText   read   fOnOutputText   write   fOnOutputText;
  property   OnErrorText   :   TOnText   read   fOnErrorText   write   fOnErrorText;
  property   OnTerminate   :   TNotifyEvent   read   fOnTerminate   write
  fOnTerminate;

  *==========
  * }
unit StdIORedirect;
{$WARN   SYMBOL_DEPRECATED   OFF}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  SyncObjs;

type
  TOnText = procedure(sender: TObject; st: string) of object;

  TStdIORedirect = class(TComponent)
  private
    fErrorRead: THandle;
    fOutputRead: THandle;
    fInputWrite: THandle;

    fErrorWrite: THandle;
    fOutputWrite: THandle;
    fInputRead: THandle;
    fProcessInfo: TProcessInformation;
    fReturnValue: DWORD;

    fOutputLineBuff: string;
    fErrorLineBuff: string;

    fErrorText: TStrings;
    fOutputText: TStrings;
    fInputText: TStrings;

    fOutputStream: TStream;
    fErrorStream: TStream;

    fOutputStreamPos: Integer;
    fErrorStreamPos: Integer;

    fOnErrorText: TOnText;
    fOnOutputText: TOnText;

    fInputEvent: TEvent;
    fRunning: boolean;
    fOnTerminate: TNotifyEvent;

    procedure CreateHandles;
    procedure DestroyHandles;
    procedure HandleOutput;
    { Private   declarations }
  protected
    property StdOutRead: THandle read fOutputRead;
    property StdInWrite: THandle read fInputWrite;
    property StdErrRead: THandle read fErrorRead;
    procedure PrepareStartupInformation(var info: TStartupInfo);

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Run(fileName, cmdLine, directory: string);
    procedure AddInputText(const st: string);
    procedure Terminate;

    property ReturnValue: DWORD read fReturnValue;
    property OutputText: TStrings read fOutputText;
    property ErrorText: TStrings read fErrorText;
    property Running: boolean read fRunning;

  published
    property OnOutputText: TOnText read fOnOutputText write fOnOutputText;
    property OnErrorText: TOnText read fOnErrorText write fOnErrorText;
    property OnTerminate: TNotifyEvent read fOnTerminate write fOnTerminate;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Misc   Units', [TStdIORedirect]);
end;

type

  TStdIOInputThread = class(TThread)
  private
    fParent: TStdIORedirect;
  protected
    procedure Execute; override;
  public
    constructor Create(AParent: TStdIORedirect);
  end;

  TStdIOOutputThread = class(TThread)
  private
    fParent: TStdIORedirect;
  protected
    procedure Execute; override;
  public
    constructor Create(AParent: TStdIORedirect);
  end;

  { TStdIORedirect }

procedure TStdIORedirect.AddInputText(const st: string);
begin
  fInputText.Add(st);
  fInputEvent.SetEvent
end;

constructor TStdIORedirect.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fOutputText := TStringList.Create;
  fErrorText := TStringList.Create;
  fInputText := TStringList.Create;
  fInputEvent := TEvent.Create(Nil, False, False, '');
end;

procedure TStdIORedirect.CreateHandles;
var
  sa: TSecurityAttributes;
  hOutputReadTmp, hErrorReadTmp, hInputWriteTmp: THandle;

begin
  DestroyHandles;

  sa.nLength := sizeof(sa);
  sa.lpSecurityDescriptor := Nil;
  sa.bInheritHandle := True;

  if not CreatePipe(hOutputReadTmp, fOutputWrite, @sa, 0) then
    RaiseLastWin32Error;

  if not CreatePipe(hErrorReadTmp, fErrorWrite, @sa, 0) then
    RaiseLastWin32Error;

  if not CreatePipe(fInputRead, hInputWriteTmp, @sa, 0) then
    RaiseLastWin32Error;

  if not DuplicateHandle(GetCurrentProcess, hOutputReadTmp, GetCurrentProcess,
    @fOutputRead, 0, False, DUPLICATE_SAME_ACCESS) then
    RaiseLastWin32Error;

  if not DuplicateHandle(GetCurrentProcess, hErrorReadTmp, GetCurrentProcess,
    @fErrorRead, 0, False, DUPLICATE_SAME_ACCESS) then
    RaiseLastWin32Error;

  if not DuplicateHandle(GetCurrentProcess, hInputWriteTmp, GetCurrentProcess,
    @fInputWrite, 0, False, DUPLICATE_SAME_ACCESS) then
    RaiseLastWin32Error;

  CloseHandle(hOutputReadTmp);
  CloseHandle(hErrorReadTmp);
  CloseHandle(hInputWriteTmp);

  fOutputStream := TMemoryStream.Create;
  fErrorStream := TMemoryStream.Create;
  fOutputStreamPos := 0;
  fErrorStreamPos := 0;

  fOutputText.Clear;
  fErrorText.Clear;
end;

destructor TStdIORedirect.Destroy;
begin
  DestroyHandles;
  fOutputText.Free;
  fErrorText.Free;
  fInputEvent.Free;
  fInputText.Free;
  inherited;
end;

procedure TStdIORedirect.DestroyHandles;
begin
  if fInputRead <> 0 then
    CloseHandle(fInputRead);
  if fOutputRead <> 0 then
    CloseHandle(fOutputRead);
  if fErrorRead <> 0 then
    CloseHandle(fErrorRead);

  if fInputWrite <> 0 then
    CloseHandle(fInputWrite);
  if fOutputWrite <> 0 then
    CloseHandle(fOutputWrite);
  if fErrorWrite <> 0 then
    CloseHandle(fErrorWrite);

  fInputRead := 0;
  fOutputRead := 0;
  fErrorRead := 0;

  fInputWrite := 0;
  fOutputWrite := 0;
  fErrorWrite := 0;

  fErrorStream.Free;
  fErrorStream := Nil;
  fOutputStream.Free;
  fOutputStream := Nil;
end;

procedure TStdIORedirect.HandleOutput;
var
  ch: char;
begin
  fOutputStream.Position := fOutputStreamPos;

  while fOutputStream.Position < fOutputStream.Size do
  begin
    fOutputStream.Read(ch, sizeof(ch));
    case ch of
      #13:
        begin
          fOutputText.Add(fOutputLineBuff);
          if Assigned(OnOutputText) then
          OnOutputText(self, fOutputLineBuff);
          fOutputLineBuff := '';
        end;

      #0 .. #12, #14 .. #31:
        ;

    else
      fOutputLineBuff := fOutputLineBuff + ch
    end
  end;

  fOutputStreamPos := fOutputStream.Position;

  fErrorStream.Position := fErrorStreamPos;

  while fErrorStream.Position < fErrorStream.Size do
  begin
    fErrorStream.Read(ch, sizeof(ch));
    case ch of
      #13:
        begin
          fErrorText.Add(fErrorLineBuff);
          if Assigned(OnErrorText) then
          OnErrorText(self, fErrorLineBuff);
          fErrorLineBuff := '';
        end;

      #0 .. #12, #14 .. #31:
        ;

    else
      fErrorLineBuff := fErrorLineBuff + ch
    end
  end;

  fErrorStreamPos := fErrorStream.Position;

end;

procedure TStdIORedirect.PrepareStartupInformation(var info: TStartupInfo);
begin
  info.cb := sizeof(info);
  info.dwFlags := info.dwFlags or STARTF_USESTDHANDLES;
  info.hStdInput := fInputRead;
  info.hStdOutput := fOutputWrite;
  info.hStdError := fErrorWrite;
end;

procedure TStdIORedirect.Run(fileName, cmdLine, directory: string);
var
  startupInfo: TStartupInfo;
  pOK: boolean;
  fName, cLine, dir: PChar;
begin
  if not Running then
  begin
    FillChar(startupInfo, sizeof(startupInfo), 0);
    CreateHandles;
    PrepareStartupInformation(startupInfo);

    if fileName <> '' then
      fName := PChar(fileName)
    else
      fName := Nil;
    if cmdLine <> '' then
      cLine := PChar(cmdLine)
    else
      cLine := Nil;
    if directory <> '' then
      dir := PChar(directory)
    else
      dir := Nil;

    pOK := CreateProcess(fName, cLine, Nil, Nil, True, CREATE_NO_WINDOW, Nil,
      dir, startupInfo, fProcessInfo);

    CloseHandle(fOutputWrite);
    fOutputWrite := 0;
    CloseHandle(fInputRead);
    fInputRead := 0;
    CloseHandle(fErrorWrite);
    fErrorWrite := 0;

    if pOK then
    begin
      fRunning := True;
      try
        TStdIOInputThread.Create(self);
        TStdIOOutputThread.Create(self);
        while MsgWaitForMultipleObjects(1, fProcessInfo.hProcess, False,
          INFINITE, QS_ALLINPUT) = WAIT_OBJECT_0 + 1 do
          Application.ProcessMessages;

        if not GetExitCodeProcess(fProcessInfo.hProcess, fReturnValue) then
          RaiseLastWin32Error;

      finally
        fInputText.Clear;
        CloseHandle(fProcessInfo.hThread);
        CloseHandle(fProcessInfo.hProcess);
        fRunning := False;
        if Assigned(OnTerminate) then
          OnTerminate(self);
      end;
    end
    else
      RaiseLastWin32Error
  end
end;

procedure TStdIORedirect.Terminate;
begin
  if Running then
    TerminateProcess(fProcessInfo.hProcess, 0);
end;

{ TStdIOInputThread }

constructor TStdIOInputThread.Create(AParent: TStdIORedirect);
begin
  inherited Create(True);
  FreeOnTerminate := True;
  fParent := AParent;
  Resume
end;

function CopyTextToPipe(handle: THandle; text: TStrings): boolean;
var
  i: Integer;
  st: string;
  bytesWritten: DWORD;
  p: Integer;
  bTerminate: boolean;
begin
  bTerminate := False;
  for i := 0 to text.Count - 1 do
  begin
    st := text[i];
    p := Pos(#26, st);
    if p > 0 then
    begin
      st := Copy(st, 1, p - 1);
      bTerminate := True;
    end
    else
      st := st + #13#10;

    if st <> '' then
      if not WriteFile(handle, st[1], Length(st), bytesWritten, Nil) then
        if GetLastError <> ERROR_NO_DATA then
          RaiseLastWin32Error;

  end;
  result := bTerminate;
  text.Clear
end;

procedure TStdIOInputThread.Execute;
var
  objects: array [0 .. 1] of THandle;
  objectNo: DWORD;
begin
  if fParent.fInputText.Count > 0 then
    fParent.fInputEvent.SetEvent;

  objects[0] := fParent.fProcessInfo.hProcess;
  objects[1] := fParent.fInputEvent.handle;

  while True do
  begin
    objectNo := WaitForMultipleObjects(2, @objects[0], False, INFINITE);

    case objectNo of
      WAIT_OBJECT_0 + 1:
        if CopyTextToPipe(fParent.fInputWrite, fParent.fInputText) then
        begin
          CloseHandle(fParent.fInputWrite);
          fParent.fInputWrite := 0;
          break
        end;
    else
      break;
    end
  end
end;

{ TStdIOOutputThread }

constructor TStdIOOutputThread.Create(AParent: TStdIORedirect);
begin
  inherited Create(True);
  FreeOnTerminate := True;
  fParent := AParent;
  Resume
end;

procedure TStdIOOutputThread.Execute;
var
  buffer: array [0 .. 1023] of char;
  bytesRead: DWORD;

begin
  while ReadFile(fParent.fOutputRead, buffer, 1024, bytesRead, Nil) and
    (bytesRead > 0) do
  begin
    fParent.fOutputStream.Seek(0, soFromEnd);
    fParent.fOutputStream.Write(buffer[0], bytesRead);
    Synchronize(fParent.HandleOutput)
  end
end;

end.
qufo 38956 2009/11/3 10:17:17
真怀疑文件头是原版自带的还是某好事者“翻译”上去的。保留个原文也好呀。
第一页 上一页 下一页 最后页 有 3 条纪录 共1页 1 - 3
 用户名:
 密 码:
自动登陆(30天有效)
 
  DELPHI盒子版权所有 1999-2012 V3.01 沪ICP备05001939号 更新RSS列表