この発言に対し以下のコメントが寄せられています

#01397　Fermion         さん　子プロセスの標準出力をリダイレクト








■概要
　名前無しパイプを利用して、起動子プロセスの標準出力をリダイレクトする
サンプルです。

■コンポーネント
　Form1 に Edit1, Memo1, Button1 を適当に配置して下さい。

■サンプル実行時
　Edit1 に 'COMMAND.COM /C dir' 等の子プロセス起動用のコマンドを入力し、
Button1 をクリックすると、Memo1 に出力結果が表示されます。

■注意事項
　・Windows98SE + Delphi5 Pro で動作確認。
　・本サンプルは、ご自身の責任においてお試し下さい。m(_"_)m

■参考発言
　・nifty:FDELPHI/MES/11/7678, nifty:FDELPHI/MES/16/1014
　　nifty:FDELPHI/MES/16/1207, nifty:FWINDC/MES/05/8277 等々。発言者の
　　方々に深謝致します。m(_"_)m

■サンプルコード
//=========================================================================
{...略...}
implementation

{$R *.DFM}

{*************************************************************************
   ExecuteCommand
   ・Command を実行し結果を FStrings に返す。
//***********************************************************************}
procedure ExecuteCommand( const Command: String; FStrings: TStrings );
const
  BufSize = 256;
var
  hReadPipe,
  hWritePipe,
  hSaveStdOut: THandle;
  Buffer     : array[ 0..BufSize - 1 ] of Char;
  SA         : TSecurityAttributes;
  PI         : TProcessInformation;
  SI         : TStartupInfo;
  {-- SecurityAttributes 設定 -------------------------------------------}
  procedure SetSecurityAttr;
  begin
    with SA do begin
      nLength              := SizeOf( TSecurityAttributes );
      bInheritHandle       := True;
      lpSecurityDescriptor := nil;
    end;{with SA do}
  end;
  {-- Standard out put handle 設定 --------------------------------------}
  procedure SetStdOutHandle( const hHandle: Cardinal );
  begin
    if not SetStdHandle( STD_OUTPUT_HANDLE, hHandle ) then
      raise Exception.Create( 'SetStdHandle に失敗しました!' );
  end;
  {-- Command 実行 ------------------------------------------------------}
  procedure CreateProc;
  begin
    FillChar( SI, SizeOf( TStartupInfo ), 0 );
    FillChar( PI, SizeOf( TProcessInformation ), 0 );
    with SI do begin
      cb := SizeOf( TStartupInfo );
      dwFlags     := STARTF_USESHOWWINDOW;
      wShowWindow := SW_HIDE; // SW_MINIMIZE;
    end;{with SI do}
    if CreateProcess( nil, PChar( Command ), nil, nil, True,
                      CREATE_DEFAULT_ERROR_MODE, nil, nil, SI, PI ) then
      begin
        CloseHandle( PI.hThread );
      end
    else raise Exception.Create( 'CreateProcess に失敗しました!' );
  end;
  {-- Pipe から実行結果出力を読み出す -----------------------------------}
  procedure ReadPipe;
  var
    BytesRead, BytesAvail, ExitCode: Cardinal;
  begin
    repeat
//      Application.ProcessMessages;
      if not GetExitCodeProcess( PI.hProcess, ExitCode ) then
        begin
          FStrings.Add( 'GetExitCodeProcess に失敗しました.' );
          Exit;
        end;{if not GetExitCodeProcess(...) then}
      if not PeekNamedPipe( hReadPipe, nil,0, nil, @BytesAvail, nil ) then
        begin
          FStrings.Add( 'PeekNamedPipe に失敗しました.' );
          Exit;
        end;{if not PeekNamedPipe(...) then}
      while BytesAvail > 0 do begin
        FillChar( Buffer, BufSize, 0 );
        if not ReadFile( hReadPipe, Buffer, BufSize, BytesRead, nil ) then
          begin
            FStrings.Add( 'Pipe からの読み出しに失敗しました.' );
            Exit;
          end;{if not ReadFile(...) then}
        FStrings.Text := FStrings.Text + String( Buffer );
        Dec( BytesAvail, BytesRead );
      end;{while BytesAvail > 0 do}
    until ( ExitCode <> STILL_ACTIVE );{repeat..}
    FStrings.Add( '' );
    FStrings.Add( 'Process 終了' );
  end;
  {----------------------------------------------------------------------}
begin
  FStrings.Clear;
  SetSecurityAttr;
  hSaveStdOut := GetStdHandle( STD_OUTPUT_HANDLE );
  try
    if CreatePipe( hReadPipe, hWritePipe, @SA, BUFSIZE ) then
      begin
        try
          try
            SetStdOutHandle( hWritePipe );
            CreateProc;
            SetStdOutHandle( hSaveStdOut );
            hSaveStdOut := INVALID_HANDLE_VALUE;
          finally
            CloseHandle( hWritePipe );
          end;{try..finally..}
          ReadPipe;
        finally
          CloseHandle( PI.hProcess );
          CloseHandle( hReadPipe );
        end;{try..finally..}
      end
    else raise Exception.Create( 'CreatePipe に失敗しました.' );
  finally
    if hSaveStdOut <> INVALID_HANDLE_VALUE then
      SetStdOutHandle( hSaveStdOut );
  end;{try..finally..(hSaveStdOut)}
end;
{*************************************************************************
   Form1 OnCreate
//***********************************************************************}
procedure TForm1.FormCreate(Sender: TObject);
begin
  with Memo1 do begin
    Font.Name := 'ＭＳ ゴシック';
    Text := '';
    ScrollBars := ssBoth;
  end;{with Memo1 do}
  Edit1.Text := 'COMMAND.COM /C dir';
end;
{*************************************************************************
   Button1 OnClick
//***********************************************************************}
procedure TForm1.Button1Click(Sender: TObject);
begin
  Screen.Cursor := crHourGlass;
  try
    ExecuteCommand( Edit1.Text, Memo1.Lines );
  finally
    Screen.Cursor := crDefault;
  end;{try..finally..}
end;
{...略...}
//=========================================================================

                              01/02/12(Mon) 01:57pm  Fermion [KHF03264]

 


Original document by Fermion         氏 ID:(KHF03264)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。