1. Уважаемые гости и пользователи форума.
    Администрация настоятельно рекомендует не регистрировать несколько аккаунтов для одного пользователя. При выявлении наличия мультиаккаунтов будут заблокированы все учетные записи данного пользователя.
    Аккаунты, зарегистрированные на временную почту будут также заблокированы.

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

Тема в разделе "Delphi", создана пользователем sergey3695, 22 сен 2018.

  1. Ветеран Модератор

    Регистрация:
    26 июн 2011
    Сообщения:
    1.185
    Симпатии:
    759
    Почему не читает проценты? Также не считывает данные с razor.
    Для FreeArc все работает, но это и не нужно.
    Код (Delphi):

    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:
     
    Последнее редактирование: 22 сен 2018
  2. Ветеран Модератор

    Регистрация:
    26 июн 2011
    Сообщения:
    1.185
    Симпатии:
    759
    Последнее редактирование: 22 сен 2018
  3. Ветеран Модератор

    Регистрация:
    26 июн 2011
    Сообщения:
    1.185
    Симпатии:
    759
    Удалил лишнее (больше половины :D)
    модуль
    Код (Delphi):
    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.
    программа
    Код (Delphi):
    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.
     

    Вложения:

    Nemko нравится это.
  4. Ветеран Модератор

    Регистрация:
    26 июн 2011
    Сообщения:
    1.185
    Симпатии:
    759
    как я понял у 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:
     
  5. Ветеран Модератор

    Регистрация:
    26 июн 2011
    Сообщения:
    1.185
    Симпатии:
    759
    Правленый 1-ый код. Слишком велика разница по весу конечного приложения 26 против ~960 кб.
    Код (Delphi):

    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.
     
     
    Последнее редактирование: 27 сен 2018

Поделиться этой страницей