Вопрос Прочитать проценты из 7z консоли

sergey3695

Ветеран
Модератор
Почему не читает проценты? Также не считывает данные с razor.
Для FreeArc все работает, но это и не нужно.
Код:
program Project4;
uses
  Windows;
{$R *.res}

function ExtractFilePath(Files: String): String; var N: Integer; S:String;
begin
  S:= Files;
if S[Length(S)]='\' then
  Delete(S,Length(S),1);
  N:= Pos('\',S);
while N > 0 do begin
  S:= Copy(S,N+1,Length(S)-N);
  N:= Pos('\',S);
end;
  Result:= Copy(Files, 0, Length(Files)-Length(S));
end;

function StrPas(const Str: PAnsiChar): string;
begin
  Result := string(Str);
end;

type
  TSysCharSet = set of AnsiChar;

function CharInSet(C: WideChar; const CharSet: TSysCharSet): Boolean;
begin
  Result := (C < #$0100) and (AnsiChar(C) in CharSet);
end;

type
  ThreadParams = record
    hReadPipe : THandle;
    s : String;
  end;

  PThreadParams = ^ThreadParams;

function ThreadRead(Info : PThreadParams):Dword; stdcall;
var
  Buffer :  array [0..$FFFF] of AnsiChar;
  nb: DWord;
begin
  Result := 0;
  while ReadFile( Info.hReadPipe,
                  buffer,
                  SizeOf(buffer),
                  nb,
                  nil) do
  begin
    Buffer[nb] := #0;
  if nb = 0 then
    Break;
    Info.s := StrPas(buffer);
end;
end;

procedure ISExtract(const FileName, CmdParams: string);
var
  hReadPipe,
  hWritePipe: THandle;
  saPipe: TSecurityAttributes;
  StartInfo: TStartupInfo;
  ProcInfo: TProcessInformation;
  Params : ThreadParams;
  ReaderID, dRunning : Dword;
  ReaderHandle : THandle;
  Line, Result, CmdLine: String;
  f1:textfile;
begin
  CmdLine := '"' + FileName + '" ' + CmdParams;
  Result := '';
  ReaderHandle := 0;
  AssignFile(f1, ExtractFilePath(ParamStr(0))+'1.txt');
  Rewrite(f1);
  saPipe.bInheritHandle := True;
  saPipe.lpSecurityDescriptor := nil;
  saPipe.nLength := SizeOf(saPipe);
  if not CreatePipe(hReadPipe,hWritePipe, @saPipe,0) then
   Messagebox(0, 'Error!','', MB_ICONERROR);
  ZeroMemory(@StartInfo, SizeOf(StartInfo));
  StartInfo.cb := SizeOf(StartInfo);
  StartInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
  StartInfo.wShowWindow := SW_SHOW;
  StartInfo.hStdInput := hWritePipe;
  StartInfo.hStdOutput := hWritePipe;
  StartInfo.hStdError:= hWritePipe;
  try
  Params.hReadPipe := hReadPipe;
  ReaderHandle := CreateThread( nil,
                                0,
                                @ThreadRead,
                                @Params,
                                0,
                                ReaderId);
  if ReaderHandle = 0 then
   Messagebox(0, 'Error!','', MB_ICONERROR);
  if CreateProcess(nil,
                   PChar(cmdline),
                   nil,
                   nil,
                   True,
                   NORMAL_PRIORITY_CLASS,
                   nil,
                   nil,
                   StartInfo,
                   ProcInfo) then
    begin
      CloseHandle(ProcInfo.hThread);
      CloseHandle(hWritePipe);
    end
  else
   Messagebox(0, 'Error!','', MB_ICONERROR);
    repeat
      dRunning := WaitForSingleObject(ProcInfo.hProcess, 500);
      Result := Params.s;
      Messagebox(0, PChar(Result),'', MB_ICONINFORMATION);
      Line:= Result;
//      Line:= Copy(Line, Pos('%', Line)-6, 6);
//      for i:=length(Line) downto 1 do
//      if not CharInSet(Line[i], ['0'..'9','.']) then
//      Delete(Line, i, 1);
      Writeln(f1, Line);
    until (dRunning <> WAIT_TIMEOUT);
  if WaitForSingleObject(ReaderHandle, infinite) = WAIT_TIMEOUT then
     begin
       TerminateThread(ReaderHandle,0);
       TerminateProcess(ProcInfo.hProcess, 1);
     end;
  finally
    if ReaderHandle > 0 then
       CloseHandle(ReaderHandle);
    if ProcInfo.hProcess > 0 then
       CloseHandle(ProcInfo.hProcess);
    if hReadPipe > 0 then
       CloseHandle(hReadPipe);
       CloseFile(f1);
  end;
end;

begin
  ISExtract(ExtractFilePath(ParamStr(0))+'7z.exe', 'x -y data.pa');
//  ISExtract(ExtractFilePath(ParamStr(0))+'arc.exe', 'x -o+  -w.\ -dp_TEST data.arc');
end.
Содержимое 1.txt
7-Zip [64] 16.02 : Copyright (c) 1999-2016 Igor Pavlov : 2016-05-21
Scanning the drive for archives:
1 file, 429933320 bytes (411 MiB)
Extracting archive: data.pa
Everything is Ok
Size: 429933189
Compressed: 429933320
Среда разработки - Delphi XE3.
Что-то не пойму как решить :scratchhead:
 
Последнее редактирование:

sergey3695

Ветеран
Модератор
Удалил лишнее (больше половины :D)
модуль
Код:
unit dprocess;

interface

uses
  windows,
  classes,
  sysutils;

type
  TProcessOption = (poRunSuspended,poWaitOnExit,
                    poUsePipes,poStderrToOutPut,
                    poNoConsole,poNewConsole,
                    poDefaultErrorMode,poNewProcessGroup,
                    poDebugProcess,poDebugOnlyThisProcess);

  TShowWindowOptions = (swoNone,swoHIDE,swoMaximize,swoMinimize,swoRestore,swoShow,
                        swoShowDefault,swoShowMaximized,swoShowMinimized,
                        swoshowMinNOActive,swoShowNA,swoShowNoActivate,swoShowNormal);

  TStartupOption = (suoUseShowWindow,suoUseSize,suoUsePosition,
                    suoUseCountChars,suoUseFillAttribute);

  TProcessPriority = (ppHigh,ppIdle,ppNormal,ppRealTime);

  TProcessOptions = set of TProcessOption;
  TStartupOptions = set of TStartupOption;

type
{ TInputPipeStream }
  TInputPipeStream = Class(THandleStream)
  end;
{ TProcess }
  TProcess = Class (TComponent)
  Private
    FProcessOptions : TProcessOptions;
    FStartupOptions : TStartupOptions;
    FProcessID : Integer;
    FProcessHandle : Thandle;
    FThreadHandle : Thandle;
    FFillAttribute : Cardinal;
    FApplicationName : string;
    FCommandLine : String;
    FCurrentDirectory : String;
    FEnvironment : Tstrings;
    FExecutable : String;
    FParameters : TStrings;
    FShowWindow : TShowWindowOptions;
    FProcessPriority : TProcessPriority;
    FPipeBufferSize : cardinal;
    Procedure FreeStreams;
    Function  GetExitStatus : Integer;
    Function  GetRunning : Boolean;
    procedure SetParameters(const AValue: TStrings);
    Procedure SetShowWindow (Value : TShowWindowOptions);
    procedure SetProcessOptions(const Value: TProcessOptions);
    function  PeekExitStatus: Boolean;
  Protected
    FRunning : Boolean;
    FExitCode : Cardinal;
    FOutputStream : TInputPipeStream;
    FStderrStream : TInputPipeStream;
    procedure CloseProcessHandles; virtual;
    Procedure CreateStreams(InHandle,OutHandle,ErrHandle : Longint);virtual;
    procedure FreeStream(var AStream: THandleStream);
  Public
    Constructor Create (AOwner : TComponent);override;
    Destructor Destroy; override;
    Procedure Execute; virtual;
    procedure CloseOutput; virtual;
    procedure CloseStderr; virtual;
    Function Resume : Integer; virtual;
    Function Suspend : Integer; virtual;
    Function Terminate (AExitCode : Integer): Boolean; virtual;
    Function WaitOnExit : Boolean;
    Property Handle : THandle Read FProcessHandle;
    Property ProcessHandle : THandle Read FProcessHandle;
    Property ThreadHandle : THandle Read FThreadHandle;
    Property Output : TInputPipeStream  Read FOutputStream;
    Property ExitStatus : Integer Read GetExitStatus;
  Published
    property PipeBufferSize : cardinal read FPipeBufferSize write FPipeBufferSize default 1024;
    Property Executable : String Read FExecutable Write FExecutable;
    Property Parameters : TStrings Read FParameters Write SetParameters;
    Property CurrentDirectory : String Read FCurrentDirectory Write FCurrentDirectory;
    Property Options : TProcessOptions Read FProcessOptions Write SetProcessOptions;
    Property Priority : TProcessPriority Read FProcessPriority Write FProcessPriority;
    Property StartupOptions : TStartupOptions Read FStartupOptions Write FStartupOptions;
    Property Running : Boolean Read GetRunning;
    Property ShowWindow : TShowWindowOptions Read FShowWindow Write SetShowWindow;
    Property FillAttribute : Cardinal read FFillAttribute Write FFillAttribute;
  end;

  EProcess = Class(Exception);

function RunCommandIndir(const curdir: string; const exename: string; const commands: array of string; out outputstring: ansistring; out exitstatus:integer; Options : TProcessOptions = []):integer; overload; //L505
function RunCommand(const exename: string; const commands: array of string; out outputstring: ansistring; Options : TProcessOptions = []):boolean; overload;// L505

implementation

Resourcestring
  SNoCommandLine        = 'Cannot execute empty command-line';
  SErrCannotExecute     = 'Failed to execute %s : %d';

Const
  PriorityConstants : Array [TProcessPriority] of Cardinal =
                      (HIGH_PRIORITY_CLASS,IDLE_PRIORITY_CLASS,
                       NORMAL_PRIORITY_CLASS,REALTIME_PRIORITY_CLASS);
  piNonInheritablePipe : TSecurityAttributes = (
                             nlength:SizeOF(TSecurityAttributes);
                             lpSecurityDescriptor:Nil;
                             Binherithandle:False);
  PipeBufSize = 1024;
type
  PSecurityAttributes = ^TSecurityAttributes;
  TSecurityAttributes = record
    nLength : DWORD;
    lpSecurityDescriptor : Pointer;
    bInheritHandle : BOOL;
  end;

Function CreatePipeHandles (Var Inhandle,OutHandle : THandle; APipeBufferSize : Cardinal = PipeBufSize) : Boolean;
begin
  Result := CreatePipe(Inhandle,OutHandle,@piNonInheritablePipe,APipeBufferSize);
end;

procedure PipeClose(const FHandle: THandle);
begin
  FileClose(FHandle);
end;

procedure TProcess.CloseProcessHandles;
begin
  if (FProcessHandle<>0) then
    CloseHandle(FProcessHandle);
  if (FThreadHandle<>0) then
    CloseHandle(FThreadHandle);
end;

Function TProcess.PeekExitStatus : Boolean;
begin
  GetExitCodeProcess(ProcessHandle,FExitCode);
  Result:=(FExitCode<>Still_Active);
end;

function GetStartupFlags (P : TProcess): Cardinal;
begin
  With P do
    begin
    Result:=0;
    if poUsePipes in FProcessOptions then
       Result:=Result or Startf_UseStdHandles;
    if suoUseShowWindow in FStartupOptions then
      Result:=Result or startf_USESHOWWINDOW;
    if suoUSESIZE in FStartupOptions then
      Result:=Result or startf_usesize;
    if suoUsePosition in FStartupOptions then
      Result:=Result or startf_USEPOSITION;
    if suoUSECOUNTCHARS in FStartupoptions then
      Result:=Result or startf_usecountchars;
    if suoUsefIllAttribute in FStartupOptions then
      Result:=Result or startf_USEFILLATTRIBUTE;
    end;
end;

function GetCreationFlags(P : TProcess) : Cardinal;
begin
  With P do
    begin
    Result:=0;
    if poNoConsole in FProcessOptions then
      Result:=Result or Detached_Process;
    if poNewConsole in FProcessOptions then
      Result:=Result or Create_new_console;
    if poNewProcessGroup in FProcessOptions then
      Result:=Result or CREATE_NEW_PROCESS_GROUP;
    If poRunSuspended in FProcessOptions Then
      Result:=Result or Create_Suspended;
    if poDebugProcess in FProcessOptions Then
      Result:=Result or DEBUG_PROCESS;
    if poDebugOnlyThisProcess in FProcessOptions Then
      Result:=Result or DEBUG_ONLY_THIS_PROCESS;
    if poDefaultErrorMode in FProcessOptions Then
      Result:=Result or CREATE_DEFAULT_ERROR_MODE;
    result:=result or PriorityConstants[FProcessPriority];
    end;
end;

function StringsToPChars(List : TStrings): pointer;
var
  EnvBlock, item: string;
  I: Integer;
  memsize: integer;
begin
  EnvBlock := '';
  For I:=0 to List.Count-1 do begin
    item := List[i];
    EnvBlock := EnvBlock + item + #0;
  end;
  EnvBlock := EnvBlock + #0;
  memsize := Length(EnvBlock);
  GetMem(Result, memsize);
  CopyMemory(Result, @EnvBlock[1], memsize);
end;

procedure InitProcessAttributes(P : TProcess; Var PA : TSecurityAttributes);
begin
  FillChar(PA,SizeOf(PA),0);
  PA.nLength := SizeOf(PA);
end;

procedure InitThreadAttributes(P : TProcess; Var TA : TSecurityAttributes);
begin
  FillChar(TA,SizeOf(TA),0);
  TA.nLength := SizeOf(TA);
end;

procedure InitStartupInfo(P : TProcess; Var SI : STARTUPINFOW);
Const
  SWC : Array [TShowWindowOptions] of Cardinal =
             (0,SW_HIDE,SW_Maximize,SW_Minimize,SW_Restore,SW_Show,
             SW_ShowDefault,SW_ShowMaximized,SW_ShowMinimized,
               SW_showMinNOActive,SW_ShowNA,SW_ShowNoActivate,SW_ShowNormal);
begin
  FillChar(SI,SizeOf(SI),0);
  With SI do
    begin
    dwFlags:=GetStartupFlags(P);
    if P.FShowWindow<>swoNone then
     dwFlags:=dwFlags or Startf_UseShowWindow
    else
      dwFlags:=dwFlags and not Startf_UseShowWindow;
    wShowWindow:=SWC[P.FShowWindow];
    if (poUsePipes in P.Options) then
      begin
      dwFlags:=dwFlags or Startf_UseStdHandles;
      end;
    if P.FillAttribute<>0 then
      begin
      dwFlags:=dwFlags or Startf_UseFillAttribute;
      dwFillAttribute:=P.FillAttribute;
      end;
    end;
end;

function DuplicateHandleFP(var handle: THandle): Boolean;
var
  oldHandle: THandle;
begin
  oldHandle := handle;
  Result := DuplicateHandle
  ( GetCurrentProcess(),
    oldHandle,
    GetCurrentProcess(),
    @handle,
    0,
    true,
    DUPLICATE_SAME_ACCESS
  );
  if Result then
    Result := CloseHandle(oldHandle);
end;

procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfoW; CE : Boolean; APipeBufferSize : Cardinal);
begin
  CreatePipeHandles(SI.hStdInput,HI, APipeBufferSize);
  DuplicateHandleFP(SI.hStdInput);
  CreatePipeHandles(HO,Si.hStdOutput, APipeBufferSize);
  DuplicateHandleFP(Si.hStdOutput);
  if CE then begin
    CreatePipeHandles(HE,SI.hStdError, APipeBufferSize);
    DuplicateHandleFP(   SI.hStdError);
    end
  else
    begin
    SI.hStdError:=SI.hStdOutput;
    HE:=HO;
    end;
end;

Function MaybeQuoteIfNotQuoted(Const S : String) : String;
begin
  If (Pos(' ',S)<>0) and (pos('"',S)=0) then
    Result:='"'+S+'"'
  else
     Result:=S;
end;

Procedure TProcess.Execute;
Var
  i : Integer;
  PCommandLine : PChar;
  FCreationFlags : Cardinal;
  FProcessAttributes : TSecurityAttributes;
  FThreadAttributes : TSecurityAttributes;
  FProcessInformation : TProcessInformation;
  FStartupInfo : STARTUPINFOW;
  HI,HO,HE : THandle;
  Cmd : String;
begin
  PCommandLine:= nil;

  if (FApplicationName='') and (FCommandLine='') and (FExecutable='') then
    Raise EProcess.Create(SNoCommandline);
  if (FApplicationName<>'') then
    begin
    PCommandLine:=PChar(FCommandLine);
    end
  else If (FCommandLine<>'') then
    PCommandLine:=PChar(FCommandLine)
  else if (Fexecutable<>'') then
    begin
    Cmd:=MaybeQuoteIfNotQuoted(Executable);
    For I:=0 to Parameters.Count-1 do
      Cmd:=Cmd+' '+MaybeQuoteIfNotQuoted(Parameters[i]);
    PCommandLine:=PChar(Cmd);
    end;

    FCreationFlags:=GetCreationFlags(Self);
    InitProcessAttributes(Self,FProcessAttributes);
    InitThreadAttributes(Self,FThreadAttributes);
    InitStartupInfo(Self,FStartUpInfo);
    If poUsePipes in FProcessOptions then begin
      CreatePipes(HI,HO,HE,FStartupInfo,Not(poStdErrToOutPut in FProcessOptions), FPipeBufferSize);
    end;
    Try
      If Not CreateProcess(nil,
                           PCommandLine,
                           @FProcessAttributes,
                           @FThreadAttributes,
                           True,
                           FCreationFlags,
                           nil,
                           nil,
                           FStartupInfo,
                           fProcessInformation) then
        Raise EProcess.CreateFmt(SErrCannotExecute,[FCommandLine,GetLastError]);
      FProcessHandle:=FProcessInformation.hProcess;
      FThreadHandle:=FProcessInformation.hThread;
      FProcessID:=FProcessINformation.dwProcessID;
    Finally
      if POUsePipes in FProcessOptions then
        begin
        FileClose(FStartupInfo.hStdInput);
        FileClose(FStartupInfo.hStdOutput);
        if Not (poStdErrToOutPut in FProcessOptions) then
          FileClose(FStartupInfo.hStdError);
        CreateStreams(HI,HO,HE);
        end;
    end;
    FRunning:=True;
  if not (csDesigning in ComponentState) and
     (poWaitOnExit in FProcessOptions) and
      not (poRunSuspended in FProcessOptions) then
    WaitOnExit;
end;

Function TProcess.WaitOnExit : Boolean;
Var
  R : DWord;
begin
  R:=WaitForSingleObject (FProcessHandle,Infinite);
  Result:=(R<>Wait_Failed);
  If Result then
    GetExitStatus;
  FRunning:=False;
end;

Function TProcess.Suspend : Longint;
begin
  Result:=SuspendThread(ThreadHandle);
end;

Function TProcess.Resume : LongInt;
begin
  Result:=ResumeThread(ThreadHandle);
end;

Function TProcess.Terminate(AExitCode : Integer) : Boolean;
begin
  Result:=False;
  If ExitStatus=Still_active then
    Result:=TerminateProcess(Handle,AexitCode);
end;

Procedure TProcess.SetShowWindow (Value : TShowWindowOptions);
begin
  FShowWindow:=Value;
end;

Constructor TProcess.Create(AOwner : TComponent);
begin
  Inherited;
  FProcessPriority:=ppNormal;
  FShowWindow:=swoNone;
  FPipeBufferSize := 1024;
  FEnvironment:=TStringList.Create;
  FParameters:=TStringList.Create;
end;

Destructor TProcess.Destroy;
begin
  FParameters.Free;
  FEnvironment.Free;
  FreeStreams;
  CloseProcessHandles;
  Inherited Destroy;
end;

Procedure TProcess.FreeStreams;
begin
  If FStderrStream<>FOutputStream then
    FreeStream(THandleStream(FStderrStream));
  FreeStream(THandleStream(FOutputStream));
end;

Function TProcess.GetExitStatus: Integer;
begin
  GetRunning;
  Result:=FExitCode;
end;

function TProcess.GetRunning : Boolean;
begin
  IF FRunning then
    FRunning:=Not PeekExitStatus;
  Result:=FRunning;
end;

procedure TProcess.CreateStreams(InHandle,OutHandle,ErrHandle : Longint);
begin
  FreeStreams;
  FOutputStream:=TInputPipeStream.Create (OutHandle);
  if Not (poStderrToOutput in FProcessOptions) then
    FStderrStream:=TInputPipeStream.Create(ErrHandle);
end;

procedure TProcess.FreeStream(var AStream: THandleStream);
begin
  if AStream = nil then exit;
  FreeAndNil(AStream);
end;

procedure TProcess.CloseOutput;
begin
  FreeStream(THandleStream(FOutputStream));
end;

procedure TProcess.CloseStderr;
begin
  FreeStream(THandleStream(FStderrStream));
end;

procedure TProcess.SetParameters(const AValue: TStrings);
begin
  FParameters.Assign(AValue);
end;

procedure TProcess.SetProcessOptions(const Value: TProcessOptions);
begin
  FProcessOptions := Value;
  If poNewConsole in FProcessOptions then
    Exclude(FProcessOptions,poNoConsole);
  if poRunSuspended in FProcessOptions then
    Exclude(FProcessOptions,poWaitOnExit);
end;

Const
  READ_BYTES = 65536; // not too small to avoid fragmentation when reading large files.

function internalRuncommand(p:TProcess;out outputstring: ansistring;
                           out exitstatus:integer):integer;
var
  numbytes,bytesread : integer;
begin
  result:=0;
  bytesread:=0;
try
  p.Options := p.Options + [poUsePipes];
  p.Execute;
  while p.Running do
  begin
    Setlength(outputstring, READ_BYTES);
    NumBytes := p.Output.Read(outputstring[1+bytesread], 255);
  if NumBytes > 0 then
    Inc(BytesRead, NumBytes);
  end;
  exitstatus:= p.exitstatus;
finally
  p.free;
end;
end;

Const
  ForbiddenOptions = [poRunSuspended,poWaitOnExit];

function RunCommandIndir(const curdir: string; const exename: string; const commands:array of string; out outputstring: ansistring;out exitstatus:integer; Options : TProcessOptions = []):integer;
Var
    p : TProcess;
    i : integer;
begin
  p:=TProcess.create(nil);
  if Options<>[] then
    P.Options:=Options - ForbiddenOptions;
  p.Executable:=exename;
  if curdir<>'' then
    p.CurrentDirectory:=curdir;
  if high(commands)>=0 then
   for i:=low(commands) to high(commands) do
     p.Parameters.add(commands[i]);
  result:=internalruncommand(p,outputstring,exitstatus);
end;

function RunCommand(const exename:string; const commands:array of string; out outputstring: ansistring; Options : TProcessOptions = []):boolean;
Var
    p : TProcess;
    i,
    exitstatus : integer;
begin
  p:=TProcess.create(nil);
  if Options<>[] then
    P.Options:=Options - ForbiddenOptions;
  p.Executable:=exename;
  if high(commands)>=0 then
   for i:=low(commands) to high(commands) do
     p.Parameters.add(commands[i]);
  result:=internalruncommand(p,outputstring,exitstatus)=0;
  if exitstatus<>0 then result:=false;
end;

end.
программа
Код:
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses dprocess;  // this is the TProcess unit from FPC, now ported to delphi

procedure OutLn(s: string); overload;
begin
  form1.memo1.lines.add(s);
end;

procedure OutLn(s: string; i: integer); overload;
begin
  outln(s + inttostr(i));
end;

function RunProcess(const Binary: string; args: TStrings): boolean;
const
  BufSize = 1024;
var
  p: TProcess;
  Buf: ansistring;
  Count: integer;
  i: integer;
  LineStart: integer;
  OutputLine: ansistring;
begin
  p := TProcess.Create(nil);
  try
    p.Executable := Binary;

    p.Options := [poUsePipes,
                  poStdErrToOutPut];
    p.ShowWindow := swoHIDE {ShowNormal};

    p.Parameters.Assign(args);
    p.Execute;

    { Now process the output }
    OutputLine:='';
    SetLength(Buf,BufSize);
    repeat
      if (p.Output<>nil) then
      begin
        Count:=p.Output.Read(pansichar(Buf)^, BufSize);
      end
      else
        Count:=0;
      LineStart:=1;
      i:=1;
      while i<=Count do
      begin
        if CharInSet(Buf[i], [#10,#13]) then
        begin
          OutputLine:=OutputLine+Copy(Buf,LineStart,i-LineStart);
          outln(String(OutputLine));
          OutputLine:='';
          if (i<Count) and (CharInset(Buf[i], [#10,#13])) and (Buf[i]<>Buf[i+1]) then
            inc(i);
          LineStart:=i+1;
        end;
        inc(i);
      end;
      OutputLine:=Copy(Buf,LineStart,Count-LineStart+1);
    until Count=0;
    if OutputLine <> '' then
      outln(String(OutputLine));
    p.WaitOnExit;
    Result := p.ExitStatus = 0;
    if not Result then
      outln('Command '+ p.Executable +' failed with exit code: ', p.ExitStatus);
  finally
    FreeAndNil(p);
  end;
end;

const
  prog = 'rz';

var args: TStringList;

procedure SetArgs;
begin
  args.add('e');
  args.add('-r');
  args.add('-y');
  args.add('data.rz');
  args.add('*');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  args := TStringList.Create;
  SetArgs;
  RunProcess(prog, args);
  args.free; args := nil;
end;

end.
 

Вложения

sergey3695

Ветеран
Модератор
как я понял у 7zip'a отключен вывод прогресса. шикарно -_-
-----
7zip developer team has opinion that, they have disabled this feature for faster extraction.. They could have provide a switch atleast that can enable the progress bar.. However, what to do above their thoughts
-----
The standard 32 and 64 bit '7-zip Extra' application accepts command line input and provides a percentage complete indicator, however I should note that this does not happen within the active CMD window, it does start its own application window, although once complete will close itself and your script will carry on as per usual.
------
:pardon:
 

sergey3695

Ветеран
Модератор
Правленый 1-ый код. Слишком велика разница по весу конечного приложения 26 против ~960 кб.
Код:
library Project5;
const
  user32    = 'user32.dll';
  kernel32  = 'kernel32.dll';
type
  HWND = NativeUInt;
  UINT = LongWord;
  WPARAM = NativeUInt;
  LPARAM = NativeInt;
  DWORD = LongWord;
  BOOL = LongBool;
  LPCWSTR = PWideChar;
  TPoint = record
    X: Longint;
    Y: Longint;
  end;
  TMsg = record
    hwnd: HWND;
    message: UINT;
    wParam: WPARAM;
    lParam: LPARAM;
    time: DWORD;
    pt: TPoint;
  end;
var
  hReadPipe : THandle=0;
  ReaderHandle : THandle=0;

function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): BOOL; stdcall; external user32 name 'PeekMessageW';
function TranslateMessage(const lpMsg: TMsg): BOOL; stdcall; external user32 name 'TranslateMessage';
function DispatchMessage(const lpMsg: TMsg): BOOL; stdcall; external user32 name 'DispatchMessageW';

procedure Application_ProcessMessages;
var
  Msg: TMsg;
  begin
  while PeekMessage(Msg, 0, 0, 0, 1) do begin
    TranslateMessage(Msg);
    DispatchMessage(Msg);
  end;
end;

function ExtractFilePath(Files: String): String; var N: Integer; S:String;
begin
  S:= Files;
if S[Length(S)]='\' then
  Delete(S,Length(S),1);
  N:= Pos('\',S);
while N > 0 do begin
  S:= Copy(S,N+1,Length(S)-N);
  N:= Pos('\',S);
end;
  Result:= Copy(Files, 0, Length(Files)-Length(S));
end;

type
  TSysCharSet = set of AnsiChar;

function CharInSet(C: AnsiChar; const CharSet: TSysCharSet): Boolean;
begin
 Result := C in CharSet;
end;

type
  ThreadParams = record
    hReadPipe : THandle;
    s : String;
  end;
  PThreadParams = ^ThreadParams;
var
  Count: integer=0;
  tmpline: AnsiString='';
  line :  array [0..$FFFF] of AnsiString; // Size lines

function progressFullLineStr(l: integer): AnsiString; stdcall;
begin
  Result:= '';
if Count<>0 then
  Result:= line[l];
end;

function progressFullLineCount: Integer; stdcall;
begin
  Result:= Count-1;
end;

type
  POverlapped = ^TOverlapped;
  _OVERLAPPED = record
    Internal: NativeUInt;
    InternalHigh: NativeUInt;
    Offset: DWORD;
    OffsetHigh: DWORD;
    hEvent: THandle;
  end;
  {$EXTERNALSYM _OVERLAPPED}
  TOverlapped = _OVERLAPPED;
  OVERLAPPED = _OVERLAPPED;
  {$EXTERNALSYM OVERLAPPED}
  PSecurityAttributes = ^TSecurityAttributes;
  _SECURITY_ATTRIBUTES = record
    nLength: DWORD;
    lpSecurityDescriptor: Pointer;
    bInheritHandle: BOOL;
  end;
  {$EXTERNALSYM _SECURITY_ATTRIBUTES}
  TSecurityAttributes = _SECURITY_ATTRIBUTES;
  SECURITY_ATTRIBUTES = _SECURITY_ATTRIBUTES;
  {$EXTERNALSYM SECURITY_ATTRIBUTES}
  PProcessInformation = ^TProcessInformation;
  _PROCESS_INFORMATION = record
    hProcess: THandle;
    hThread: THandle;
    dwProcessId: DWORD;
    dwThreadId: DWORD;
  end;
  {$EXTERNALSYM _PROCESS_INFORMATION}
  TProcessInformation = _PROCESS_INFORMATION;
  PROCESS_INFORMATION = _PROCESS_INFORMATION;
  {$EXTERNALSYM PROCESS_INFORMATION}
  _STARTUPINFOW = record
    cb: DWORD;
    lpReserved: PWideChar;
    lpDesktop: PWideChar;
    lpTitle: PWideChar;
    dwX: DWORD;
    dwY: DWORD;
    dwXSize: DWORD;
    dwYSize: DWORD;
    dwXCountChars: DWORD;
    dwYCountChars: DWORD;
    dwFillAttribute: DWORD;
    dwFlags: DWORD;
    wShowWindow: Word;
    cbReserved2: Word;
    lpReserved2: PByte;
    hStdInput: THandle;
    hStdOutput: THandle;
    hStdError: THandle;
  end;
  TStartupInfo = _STARTUPINFOW;

function ReadFile(hFile: THandle; var Buffer; nNumberOfBytesToRead: DWORD; var lpNumberOfBytesRead: DWORD; lpOverlapped: POverlapped): BOOL; stdcall; external kernel32 name 'ReadFile';

function ThreadRead(Info : PThreadParams):Dword; stdcall;
var
  Buffer :  array [0..$FFFF] of AnsiChar;
  nb: DWord;
  i: Longint;
begin
  Info^.s:= '';
  Result := 0;
while ReadFile(Info^.hReadPipe,  buffer,  SizeOf(buffer),  nb,  nil) do
begin
  if nb = 0 then
    Break;
  for i:=0 to nb-1 do
  begin
  if CharInSet(buffer[i], ['A'..'Z', 'a'..'z', '0'..'9', '.', ' ', '%', ',', '.', '!', '&', '?', '@', '*', '/', '\', '-', '_', '=', '+', '#', '$', '№', '~', ';', '^', ':', ')', '(']) then
    tmpline := tmpline + buffer[i];
  end;
    line[Count]:= tmpline;
    tmpline:= '';
    Count:= Count+1;
end;
if Count<>0 then
  Result := 1;
//   for l:=0 to Count-1 do
//   Info^.s:= Info^.s + #13#10 + line[l];
end;

Const
  PipeBufSize = 1024;
  MB_ICONERROR = $00000010;
  STARTF_USESHOWWINDOW = 1;
  STARTF_USESTDHANDLES = $100;
  SW_HIDE = 0;
  SW_SHOWNORMAL = 1;
  WAIT_TIMEOUT = $00000102;
var
  FRunning : Boolean;
  StartInfo: TStartupInfo;
  ProcInfo: TProcessInformation;

function CreatePipe(var hReadPipe, hWritePipe: THandle; lpPipeAttributes: PSecurityAttributes; nSize: DWORD): BOOL; stdcall; external kernel32 name 'CreatePipe';
function MessageBox(hWnd: HWND; lpText, lpCaption: PWideChar; uType: UINT): Integer; stdcall; external user32 name 'MessageBoxW';

procedure ZeroMemory(Destination: Pointer; Length: NativeUInt);
begin
  FillChar(Destination^, Length, 0);
end;

function CreateThread(lpThreadAttributes: Pointer; dwStackSize: NativeUInt; lpStartAddress: Pointer; lpParameter: Pointer; dwCreationFlags: DWORD; var lpThreadId: DWORD): THandle; stdcall; external kernel32 name 'CreateThread';
function TerminateThread(hThread: THandle; dwExitCode: DWORD): BOOL; stdcall; external kernel32 name 'TerminateThread';
function CreateProcess(lpApplicationName: PWideChar; lpCommandLine: PWideChar;  lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfo; var lpProcessInformation: TProcessInformation): BOOL; stdcall; external kernel32 name 'CreateProcessW';
function CloseHandle(hObject: THandle): BOOL; stdcall; external kernel32 name 'CloseHandle';
function TerminateProcess(hProcess: THandle; uExitCode: UINT): BOOL; stdcall; external kernel32 name 'TerminateProcess';
function WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD; stdcall; external kernel32 name 'WaitForSingleObject';

procedure ISExtract(const FileName, CmdParams: string; CmdPipe, ShowCmd: boolean; Priority: integer); stdcall;
var
  hWritePipe: THandle;
  saPipe: TSecurityAttributes;
  Params : ThreadParams;
  ReaderID : Dword;
  CmdLine: String;
begin
  CmdLine := '"' + FileName + '" ' + CmdParams;
if CmdPipe then
begin
  saPipe.bInheritHandle := True;
  saPipe.lpSecurityDescriptor := nil;
  saPipe.nLength := SizeOf(saPipe);
  if not CreatePipe(hReadPipe,hWritePipe, @saPipe, PipeBufSize) then
    Messagebox(0, 'Error!','', MB_ICONERROR);
end;
  ZeroMemory(@StartInfo, SizeOf(StartInfo));
  StartInfo.cb := SizeOf(StartInfo);
if CmdPipe then
begin
  StartInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
  StartInfo.hStdInput := hWritePipe;
  StartInfo.hStdOutput := hWritePipe;
  StartInfo.hStdError:= hWritePipe;
end else
  StartInfo.dwFlags := STARTF_USESHOWWINDOW;
if ShowCmd then
  StartInfo.wShowWindow := SW_SHOWNORMAL
  else
  StartInfo.wShowWindow := SW_HIDE;
try
if CmdPipe then
begin
  Params.hReadPipe := hReadPipe;
  ReaderHandle := CreateThread( nil,
                                0,
                                @ThreadRead,
                                @Params,
                                0,
                                ReaderId);
  if ReaderHandle = 0 then
  begin
    Messagebox(0, 'Error!','', MB_ICONERROR);
    TerminateThread(ReaderHandle,0);
  end;
end;
  if CreateProcess(nil,
                   PChar(cmdline),
                   nil,
                   nil,
                   true,
                   Priority,
                   nil,
                   nil,
                   StartInfo,
                   ProcInfo) then
    begin
      FRunning:= True;
      CloseHandle(ProcInfo.hThread);
    if CmdPipe then
      CloseHandle(hWritePipe);
    end
  else begin
    Messagebox(0, 'Error!','', MB_ICONERROR);
  if CmdPipe then
    TerminateThread(ReaderHandle,0);
    TerminateProcess(ProcInfo.hProcess, 1);
  end;
  repeat
    Application_ProcessMessages;
  until WaitforSingleObject(ProcInfo.hProcess, 50) <> WAIT_TIMEOUT;
  finally
    if ProcInfo.hProcess > 0 then
       CloseHandle(ProcInfo.hProcess);
    if hReadPipe > 0 then
       CloseHandle(hReadPipe);
    if ReaderHandle > 0 then
       CloseHandle(ReaderHandle);
  end;
end;

function ISProcessStatus: Dword; stdcall;
begin
if FRunning then
  Result:= WaitforSingleObject(ProcInfo.hProcess, 50)
else
  Result:= 0;
end;

const
  WM_CLOSE = $10;

function FindWindowEx(Parent, Child: HWND; ClassName, WindowName: LPCWSTR): HWND; stdcall; external user32 name 'FindWindowExW';
function GetWindowThreadProcessId(hWnd: HWND; lpdwProcessId: Pointer = nil): DWORD; stdcall; overload; external user32 name 'GetWindowThreadProcessId';
function PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL; stdcall; external user32 name 'PostMessageW';

procedure ISProcessClose; stdcall;
var
  h: HWND;
  pid: DWord;
begin
  if FRunning then
  begin
    h := FindWindowEx(0, 0, nil, nil);
    while (h <> 0) do
    begin
      GetWindowThreadProcessId(h, @pid);
    if (pid = ProcInfo.dwProcessId) then
      PostMessage(h,WM_CLOSE,0,0);
      h := FindWindowEx(0, h, nil, nil);
    end;
  end;
end;

exports
  ISExtract,
  progressFullLineStr, progressFullLineCount,
  ISProcessStatus, ISProcessClose;
begin
end.
 
Последнее редактирование:
Сверху