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

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

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

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

    Регистрация:
    26 июн 2011
    Сообщения:
    1.329
    Симпатии:
    867
    Почему не читает проценты? Также не считывает данные с razor.
    Для FreeArc все работает, но это и не нужно.
    Код (Delphi):
    1.  
    2. program Project4;
    3. uses
    4.   Windows;
    5. {$R *.res}
    6.  
    7. function ExtractFilePath(Files: String): String; var N: Integer; S:String;
    8. begin
    9.   S:= Files;
    10. if S[Length(S)]='\' then
    11.   Delete(S,Length(S),1);
    12.   N:= Pos('\',S);
    13. while N > 0 do begin
    14.   S:= Copy(S,N+1,Length(S)-N);
    15.   N:= Pos('\',S);
    16. end;
    17.   Result:= Copy(Files, 0, Length(Files)-Length(S));
    18. end;
    19.  
    20. function StrPas(const Str: PAnsiChar): string;
    21. begin
    22.   Result := string(Str);
    23. end;
    24.  
    25. type
    26.   TSysCharSet = set of AnsiChar;
    27.  
    28. function CharInSet(C: WideChar; const CharSet: TSysCharSet): Boolean;
    29. begin
    30.   Result := (C < #$0100) and (AnsiChar(C) in CharSet);
    31. end;
    32.  
    33. type
    34.   ThreadParams = record
    35.     hReadPipe : THandle;
    36.     s : String;
    37.   end;
    38.  
    39.   PThreadParams = ^ThreadParams;
    40.  
    41. function ThreadRead(Info : PThreadParams):Dword; stdcall;
    42. var
    43.   Buffer :  array [0..$FFFF] of AnsiChar;
    44.   nb: DWord;
    45. begin
    46.   Result := 0;
    47.   while ReadFile( Info.hReadPipe,
    48.                   buffer,
    49.                   SizeOf(buffer),
    50.                   nb,
    51.                   nil) do
    52.   begin
    53.     Buffer[nb] := #0;
    54.   if nb = 0 then
    55.     Break;
    56.     Info.s := StrPas(buffer);
    57. end;
    58. end;
    59.  
    60. procedure ISExtract(const FileName, CmdParams: string);
    61. var
    62.   hReadPipe,
    63.   hWritePipe: THandle;
    64.   saPipe: TSecurityAttributes;
    65.   StartInfo: TStartupInfo;
    66.   ProcInfo: TProcessInformation;
    67.   Params : ThreadParams;
    68.   ReaderID, dRunning : Dword;
    69.   ReaderHandle : THandle;
    70.   Line, Result, CmdLine: String;
    71.   f1:textfile;
    72. begin
    73.   CmdLine := '"' + FileName + '" ' + CmdParams;
    74.   Result := '';
    75.   ReaderHandle := 0;
    76.   AssignFile(f1, ExtractFilePath(ParamStr(0))+'1.txt');
    77.   Rewrite(f1);
    78.   saPipe.bInheritHandle := True;
    79.   saPipe.lpSecurityDescriptor := nil;
    80.   saPipe.nLength := SizeOf(saPipe);
    81.   if not CreatePipe(hReadPipe,hWritePipe, @saPipe,0) then
    82.    Messagebox(0, 'Error!','', MB_ICONERROR);
    83.   ZeroMemory(@StartInfo, SizeOf(StartInfo));
    84.   StartInfo.cb := SizeOf(StartInfo);
    85.   StartInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
    86.   StartInfo.wShowWindow := SW_SHOW;
    87.   StartInfo.hStdInput := hWritePipe;
    88.   StartInfo.hStdOutput := hWritePipe;
    89.   StartInfo.hStdError:= hWritePipe;
    90.   try
    91.   Params.hReadPipe := hReadPipe;
    92.   ReaderHandle := CreateThread( nil,
    93.                                 0,
    94.                                 @ThreadRead,
    95.                                 @Params,
    96.                                 0,
    97.                                 ReaderId);
    98.   if ReaderHandle = 0 then
    99.    Messagebox(0, 'Error!','', MB_ICONERROR);
    100.   if CreateProcess(nil,
    101.                    PChar(cmdline),
    102.                    nil,
    103.                    nil,
    104.                    True,
    105.                    NORMAL_PRIORITY_CLASS,
    106.                    nil,
    107.                    nil,
    108.                    StartInfo,
    109.                    ProcInfo) then
    110.     begin
    111.       CloseHandle(ProcInfo.hThread);
    112.       CloseHandle(hWritePipe);
    113.     end
    114.   else
    115.    Messagebox(0, 'Error!','', MB_ICONERROR);
    116.     repeat
    117.       dRunning := WaitForSingleObject(ProcInfo.hProcess, 500);
    118.       Result := Params.s;
    119.       Messagebox(0, PChar(Result),'', MB_ICONINFORMATION);
    120.       Line:= Result;
    121. //      Line:= Copy(Line, Pos('%', Line)-6, 6);
    122. //      for i:=length(Line) downto 1 do
    123. //      if not CharInSet(Line[i], ['0'..'9','.']) then
    124. //      Delete(Line, i, 1);
    125.       Writeln(f1, Line);
    126.     until (dRunning <> WAIT_TIMEOUT);
    127.   if WaitForSingleObject(ReaderHandle, infinite) = WAIT_TIMEOUT then
    128.      begin
    129.        TerminateThread(ReaderHandle,0);
    130.        TerminateProcess(ProcInfo.hProcess, 1);
    131.      end;
    132.   finally
    133.     if ReaderHandle > 0 then
    134.        CloseHandle(ReaderHandle);
    135.     if ProcInfo.hProcess > 0 then
    136.        CloseHandle(ProcInfo.hProcess);
    137.     if hReadPipe > 0 then
    138.        CloseHandle(hReadPipe);
    139.        CloseFile(f1);
    140.   end;
    141. end;
    142.  
    143. begin
    144.   ISExtract(ExtractFilePath(ParamStr(0))+'7z.exe', 'x -y data.pa');
    145. //  ISExtract(ExtractFilePath(ParamStr(0))+'arc.exe', 'x -o+  -w.\ -dp_TEST data.arc');
    146. end.
    147.  
    Содержимое 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.329
    Симпатии:
    867
    Последнее редактирование: 22 сен 2018
  3. Ветеран Модератор

    Регистрация:
    26 июн 2011
    Сообщения:
    1.329
    Симпатии:
    867
    Удалил лишнее (больше половины :D)
    модуль
    Код (Delphi):
    1. unit dprocess;
    2.  
    3. interface
    4.  
    5. uses
    6.   windows,
    7.   classes,
    8.   sysutils;
    9.  
    10. type
    11.   TProcessOption = (poRunSuspended,poWaitOnExit,
    12.                     poUsePipes,poStderrToOutPut,
    13.                     poNoConsole,poNewConsole,
    14.                     poDefaultErrorMode,poNewProcessGroup,
    15.                     poDebugProcess,poDebugOnlyThisProcess);
    16.  
    17.   TShowWindowOptions = (swoNone,swoHIDE,swoMaximize,swoMinimize,swoRestore,swoShow,
    18.                         swoShowDefault,swoShowMaximized,swoShowMinimized,
    19.                         swoshowMinNOActive,swoShowNA,swoShowNoActivate,swoShowNormal);
    20.  
    21.   TStartupOption = (suoUseShowWindow,suoUseSize,suoUsePosition,
    22.                     suoUseCountChars,suoUseFillAttribute);
    23.  
    24.   TProcessPriority = (ppHigh,ppIdle,ppNormal,ppRealTime);
    25.  
    26.   TProcessOptions = set of TProcessOption;
    27.   TStartupOptions = set of TStartupOption;
    28.  
    29. type
    30. { TInputPipeStream }
    31.   TInputPipeStream = Class(THandleStream)
    32.   end;
    33. { TProcess }
    34.   TProcess = Class (TComponent)
    35.   Private
    36.     FProcessOptions : TProcessOptions;
    37.     FStartupOptions : TStartupOptions;
    38.     FProcessID : Integer;
    39.     FProcessHandle : Thandle;
    40.     FThreadHandle : Thandle;
    41.     FFillAttribute : Cardinal;
    42.     FApplicationName : string;
    43.     FCommandLine : String;
    44.     FCurrentDirectory : String;
    45.     FEnvironment : Tstrings;
    46.     FExecutable : String;
    47.     FParameters : TStrings;
    48.     FShowWindow : TShowWindowOptions;
    49.     FProcessPriority : TProcessPriority;
    50.     FPipeBufferSize : cardinal;
    51.     Procedure FreeStreams;
    52.     Function  GetExitStatus : Integer;
    53.     Function  GetRunning : Boolean;
    54.     procedure SetParameters(const AValue: TStrings);
    55.     Procedure SetShowWindow (Value : TShowWindowOptions);
    56.     procedure SetProcessOptions(const Value: TProcessOptions);
    57.     function  PeekExitStatus: Boolean;
    58.   Protected
    59.     FRunning : Boolean;
    60.     FExitCode : Cardinal;
    61.     FOutputStream : TInputPipeStream;
    62.     FStderrStream : TInputPipeStream;
    63.     procedure CloseProcessHandles; virtual;
    64.     Procedure CreateStreams(InHandle,OutHandle,ErrHandle : Longint);virtual;
    65.     procedure FreeStream(var AStream: THandleStream);
    66.   Public
    67.     Constructor Create (AOwner : TComponent);override;
    68.     Destructor Destroy; override;
    69.     Procedure Execute; virtual;
    70.     procedure CloseOutput; virtual;
    71.     procedure CloseStderr; virtual;
    72.     Function Resume : Integer; virtual;
    73.     Function Suspend : Integer; virtual;
    74.     Function Terminate (AExitCode : Integer): Boolean; virtual;
    75.     Function WaitOnExit : Boolean;
    76.     Property Handle : THandle Read FProcessHandle;
    77.     Property ProcessHandle : THandle Read FProcessHandle;
    78.     Property ThreadHandle : THandle Read FThreadHandle;
    79.     Property Output : TInputPipeStream  Read FOutputStream;
    80.     Property ExitStatus : Integer Read GetExitStatus;
    81.   Published
    82.     property PipeBufferSize : cardinal read FPipeBufferSize write FPipeBufferSize default 1024;
    83.     Property Executable : String Read FExecutable Write FExecutable;
    84.     Property Parameters : TStrings Read FParameters Write SetParameters;
    85.     Property CurrentDirectory : String Read FCurrentDirectory Write FCurrentDirectory;
    86.     Property Options : TProcessOptions Read FProcessOptions Write SetProcessOptions;
    87.     Property Priority : TProcessPriority Read FProcessPriority Write FProcessPriority;
    88.     Property StartupOptions : TStartupOptions Read FStartupOptions Write FStartupOptions;
    89.     Property Running : Boolean Read GetRunning;
    90.     Property ShowWindow : TShowWindowOptions Read FShowWindow Write SetShowWindow;
    91.     Property FillAttribute : Cardinal read FFillAttribute Write FFillAttribute;
    92.   end;
    93.  
    94.   EProcess = Class(Exception);
    95.  
    96. function RunCommandIndir(const curdir: string; const exename: string; const commands: array of string; out outputstring: ansistring; out exitstatus:integer; Options : TProcessOptions = []):integer; overload; //L505
    97. function RunCommand(const exename: string; const commands: array of string; out outputstring: ansistring; Options : TProcessOptions = []):boolean; overload;// L505
    98.  
    99. implementation
    100.  
    101. Resourcestring
    102.   SNoCommandLine        = 'Cannot execute empty command-line';
    103.   SErrCannotExecute     = 'Failed to execute %s : %d';
    104.  
    105. Const
    106.   PriorityConstants : Array [TProcessPriority] of Cardinal =
    107.                       (HIGH_PRIORITY_CLASS,IDLE_PRIORITY_CLASS,
    108.                        NORMAL_PRIORITY_CLASS,REALTIME_PRIORITY_CLASS);
    109.   piNonInheritablePipe : TSecurityAttributes = (
    110.                              nlength:SizeOF(TSecurityAttributes);
    111.                              lpSecurityDescriptor:Nil;
    112.                              Binherithandle:False);
    113.   PipeBufSize = 1024;
    114. type
    115.   PSecurityAttributes = ^TSecurityAttributes;
    116.   TSecurityAttributes = record
    117.     nLength : DWORD;
    118.     lpSecurityDescriptor : Pointer;
    119.     bInheritHandle : BOOL;
    120.   end;
    121.  
    122. Function CreatePipeHandles (Var Inhandle,OutHandle : THandle; APipeBufferSize : Cardinal = PipeBufSize) : Boolean;
    123. begin
    124.   Result := CreatePipe(Inhandle,OutHandle,@piNonInheritablePipe,APipeBufferSize);
    125. end;
    126.  
    127. procedure PipeClose(const FHandle: THandle);
    128. begin
    129.   FileClose(FHandle);
    130. end;
    131.  
    132. procedure TProcess.CloseProcessHandles;
    133. begin
    134.   if (FProcessHandle<>0) then
    135.     CloseHandle(FProcessHandle);
    136.   if (FThreadHandle<>0) then
    137.     CloseHandle(FThreadHandle);
    138. end;
    139.  
    140. Function TProcess.PeekExitStatus : Boolean;
    141. begin
    142.   GetExitCodeProcess(ProcessHandle,FExitCode);
    143.   Result:=(FExitCode<>Still_Active);
    144. end;
    145.  
    146. function GetStartupFlags (P : TProcess): Cardinal;
    147. begin
    148.   With P do
    149.     begin
    150.     Result:=0;
    151.     if poUsePipes in FProcessOptions then
    152.        Result:=Result or Startf_UseStdHandles;
    153.     if suoUseShowWindow in FStartupOptions then
    154.       Result:=Result or startf_USESHOWWINDOW;
    155.     if suoUSESIZE in FStartupOptions then
    156.       Result:=Result or startf_usesize;
    157.     if suoUsePosition in FStartupOptions then
    158.       Result:=Result or startf_USEPOSITION;
    159.     if suoUSECOUNTCHARS in FStartupoptions then
    160.       Result:=Result or startf_usecountchars;
    161.     if suoUsefIllAttribute in FStartupOptions then
    162.       Result:=Result or startf_USEFILLATTRIBUTE;
    163.     end;
    164. end;
    165.  
    166. function GetCreationFlags(P : TProcess) : Cardinal;
    167. begin
    168.   With P do
    169.     begin
    170.     Result:=0;
    171.     if poNoConsole in FProcessOptions then
    172.       Result:=Result or Detached_Process;
    173.     if poNewConsole in FProcessOptions then
    174.       Result:=Result or Create_new_console;
    175.     if poNewProcessGroup in FProcessOptions then
    176.       Result:=Result or CREATE_NEW_PROCESS_GROUP;
    177.     If poRunSuspended in FProcessOptions Then
    178.       Result:=Result or Create_Suspended;
    179.     if poDebugProcess in FProcessOptions Then
    180.       Result:=Result or DEBUG_PROCESS;
    181.     if poDebugOnlyThisProcess in FProcessOptions Then
    182.       Result:=Result or DEBUG_ONLY_THIS_PROCESS;
    183.     if poDefaultErrorMode in FProcessOptions Then
    184.       Result:=Result or CREATE_DEFAULT_ERROR_MODE;
    185.     result:=result or PriorityConstants[FProcessPriority];
    186.     end;
    187. end;
    188.  
    189. function StringsToPChars(List : TStrings): pointer;
    190. var
    191.   EnvBlock, item: string;
    192.   I: Integer;
    193.   memsize: integer;
    194. begin
    195.   EnvBlock := '';
    196.   For I:=0 to List.Count-1 do begin
    197.     item := List[i];
    198.     EnvBlock := EnvBlock + item + #0;
    199.   end;
    200.   EnvBlock := EnvBlock + #0;
    201.   memsize := Length(EnvBlock);
    202.   GetMem(Result, memsize);
    203.   CopyMemory(Result, @EnvBlock[1], memsize);
    204. end;
    205.  
    206. procedure InitProcessAttributes(P : TProcess; Var PA : TSecurityAttributes);
    207. begin
    208.   FillChar(PA,SizeOf(PA),0);
    209.   PA.nLength := SizeOf(PA);
    210. end;
    211.  
    212. procedure InitThreadAttributes(P : TProcess; Var TA : TSecurityAttributes);
    213. begin
    214.   FillChar(TA,SizeOf(TA),0);
    215.   TA.nLength := SizeOf(TA);
    216. end;
    217.  
    218. procedure InitStartupInfo(P : TProcess; Var SI : STARTUPINFOW);
    219. Const
    220.   SWC : Array [TShowWindowOptions] of Cardinal =
    221.              (0,SW_HIDE,SW_Maximize,SW_Minimize,SW_Restore,SW_Show,
    222.              SW_ShowDefault,SW_ShowMaximized,SW_ShowMinimized,
    223.                SW_showMinNOActive,SW_ShowNA,SW_ShowNoActivate,SW_ShowNormal);
    224. begin
    225.   FillChar(SI,SizeOf(SI),0);
    226.   With SI do
    227.     begin
    228.     dwFlags:=GetStartupFlags(P);
    229.     if P.FShowWindow<>swoNone then
    230.      dwFlags:=dwFlags or Startf_UseShowWindow
    231.     else
    232.       dwFlags:=dwFlags and not Startf_UseShowWindow;
    233.     wShowWindow:=SWC[P.FShowWindow];
    234.     if (poUsePipes in P.Options) then
    235.       begin
    236.       dwFlags:=dwFlags or Startf_UseStdHandles;
    237.       end;
    238.     if P.FillAttribute<>0 then
    239.       begin
    240.       dwFlags:=dwFlags or Startf_UseFillAttribute;
    241.       dwFillAttribute:=P.FillAttribute;
    242.       end;
    243.     end;
    244. end;
    245.  
    246. function DuplicateHandleFP(var handle: THandle): Boolean;
    247. var
    248.   oldHandle: THandle;
    249. begin
    250.   oldHandle := handle;
    251.   Result := DuplicateHandle
    252.   ( GetCurrentProcess(),
    253.     oldHandle,
    254.     GetCurrentProcess(),
    255.     @handle,
    256.     0,
    257.     true,
    258.     DUPLICATE_SAME_ACCESS
    259.   );
    260.   if Result then
    261.     Result := CloseHandle(oldHandle);
    262. end;
    263.  
    264. procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfoW; CE : Boolean; APipeBufferSize : Cardinal);
    265. begin
    266.   CreatePipeHandles(SI.hStdInput,HI, APipeBufferSize);
    267.   DuplicateHandleFP(SI.hStdInput);
    268.   CreatePipeHandles(HO,Si.hStdOutput, APipeBufferSize);
    269.   DuplicateHandleFP(Si.hStdOutput);
    270.   if CE then begin
    271.     CreatePipeHandles(HE,SI.hStdError, APipeBufferSize);
    272.     DuplicateHandleFP(   SI.hStdError);
    273.     end
    274.   else
    275.     begin
    276.     SI.hStdError:=SI.hStdOutput;
    277.     HE:=HO;
    278.     end;
    279. end;
    280.  
    281. Function MaybeQuoteIfNotQuoted(Const S : String) : String;
    282. begin
    283.   If (Pos(' ',S)<>0) and (pos('"',S)=0) then
    284.     Result:='"'+S+'"'
    285.   else
    286.      Result:=S;
    287. end;
    288.  
    289. Procedure TProcess.Execute;
    290. Var
    291.   i : Integer;
    292.   PCommandLine : PChar;
    293.   FCreationFlags : Cardinal;
    294.   FProcessAttributes : TSecurityAttributes;
    295.   FThreadAttributes : TSecurityAttributes;
    296.   FProcessInformation : TProcessInformation;
    297.   FStartupInfo : STARTUPINFOW;
    298.   HI,HO,HE : THandle;
    299.   Cmd : String;
    300. begin
    301.   PCommandLine:= nil;
    302.  
    303.   if (FApplicationName='') and (FCommandLine='') and (FExecutable='') then
    304.     Raise EProcess.Create(SNoCommandline);
    305.   if (FApplicationName<>'') then
    306.     begin
    307.     PCommandLine:=PChar(FCommandLine);
    308.     end
    309.   else If (FCommandLine<>'') then
    310.     PCommandLine:=PChar(FCommandLine)
    311.   else if (Fexecutable<>'') then
    312.     begin
    313.     Cmd:=MaybeQuoteIfNotQuoted(Executable);
    314.     For I:=0 to Parameters.Count-1 do
    315.       Cmd:=Cmd+' '+MaybeQuoteIfNotQuoted(Parameters[i]);
    316.     PCommandLine:=PChar(Cmd);
    317.     end;
    318.  
    319.     FCreationFlags:=GetCreationFlags(Self);
    320.     InitProcessAttributes(Self,FProcessAttributes);
    321.     InitThreadAttributes(Self,FThreadAttributes);
    322.     InitStartupInfo(Self,FStartUpInfo);
    323.     If poUsePipes in FProcessOptions then begin
    324.       CreatePipes(HI,HO,HE,FStartupInfo,Not(poStdErrToOutPut in FProcessOptions), FPipeBufferSize);
    325.     end;
    326.     Try
    327.       If Not CreateProcess(nil,
    328.                            PCommandLine,
    329.                            @FProcessAttributes,
    330.                            @FThreadAttributes,
    331.                            True,
    332.                            FCreationFlags,
    333.                            nil,
    334.                            nil,
    335.                            FStartupInfo,
    336.                            fProcessInformation) then
    337.         Raise EProcess.CreateFmt(SErrCannotExecute,[FCommandLine,GetLastError]);
    338.       FProcessHandle:=FProcessInformation.hProcess;
    339.       FThreadHandle:=FProcessInformation.hThread;
    340.       FProcessID:=FProcessINformation.dwProcessID;
    341.     Finally
    342.       if POUsePipes in FProcessOptions then
    343.         begin
    344.         FileClose(FStartupInfo.hStdInput);
    345.         FileClose(FStartupInfo.hStdOutput);
    346.         if Not (poStdErrToOutPut in FProcessOptions) then
    347.           FileClose(FStartupInfo.hStdError);
    348.         CreateStreams(HI,HO,HE);
    349.         end;
    350.     end;
    351.     FRunning:=True;
    352.   if not (csDesigning in ComponentState) and
    353.      (poWaitOnExit in FProcessOptions) and
    354.       not (poRunSuspended in FProcessOptions) then
    355.     WaitOnExit;
    356. end;
    357.  
    358. Function TProcess.WaitOnExit : Boolean;
    359. Var
    360.   R : DWord;
    361. begin
    362.   R:=WaitForSingleObject (FProcessHandle,Infinite);
    363.   Result:=(R<>Wait_Failed);
    364.   If Result then
    365.     GetExitStatus;
    366.   FRunning:=False;
    367. end;
    368.  
    369. Function TProcess.Suspend : Longint;
    370. begin
    371.   Result:=SuspendThread(ThreadHandle);
    372. end;
    373.  
    374. Function TProcess.Resume : LongInt;
    375. begin
    376.   Result:=ResumeThread(ThreadHandle);
    377. end;
    378.  
    379. Function TProcess.Terminate(AExitCode : Integer) : Boolean;
    380. begin
    381.   Result:=False;
    382.   If ExitStatus=Still_active then
    383.     Result:=TerminateProcess(Handle,AexitCode);
    384. end;
    385.  
    386. Procedure TProcess.SetShowWindow (Value : TShowWindowOptions);
    387. begin
    388.   FShowWindow:=Value;
    389. end;
    390.  
    391. Constructor TProcess.Create(AOwner : TComponent);
    392. begin
    393.   Inherited;
    394.   FProcessPriority:=ppNormal;
    395.   FShowWindow:=swoNone;
    396.   FPipeBufferSize := 1024;
    397.   FEnvironment:=TStringList.Create;
    398.   FParameters:=TStringList.Create;
    399. end;
    400.  
    401. Destructor TProcess.Destroy;
    402. begin
    403.   FParameters.Free;
    404.   FEnvironment.Free;
    405.   FreeStreams;
    406.   CloseProcessHandles;
    407.   Inherited Destroy;
    408. end;
    409.  
    410. Procedure TProcess.FreeStreams;
    411. begin
    412.   If FStderrStream<>FOutputStream then
    413.     FreeStream(THandleStream(FStderrStream));
    414.   FreeStream(THandleStream(FOutputStream));
    415. end;
    416.  
    417. Function TProcess.GetExitStatus: Integer;
    418. begin
    419.   GetRunning;
    420.   Result:=FExitCode;
    421. end;
    422.  
    423. function TProcess.GetRunning : Boolean;
    424. begin
    425.   IF FRunning then
    426.     FRunning:=Not PeekExitStatus;
    427.   Result:=FRunning;
    428. end;
    429.  
    430. procedure TProcess.CreateStreams(InHandle,OutHandle,ErrHandle : Longint);
    431. begin
    432.   FreeStreams;
    433.   FOutputStream:=TInputPipeStream.Create (OutHandle);
    434.   if Not (poStderrToOutput in FProcessOptions) then
    435.     FStderrStream:=TInputPipeStream.Create(ErrHandle);
    436. end;
    437.  
    438. procedure TProcess.FreeStream(var AStream: THandleStream);
    439. begin
    440.   if AStream = nil then exit;
    441.   FreeAndNil(AStream);
    442. end;
    443.  
    444. procedure TProcess.CloseOutput;
    445. begin
    446.   FreeStream(THandleStream(FOutputStream));
    447. end;
    448.  
    449. procedure TProcess.CloseStderr;
    450. begin
    451.   FreeStream(THandleStream(FStderrStream));
    452. end;
    453.  
    454. procedure TProcess.SetParameters(const AValue: TStrings);
    455. begin
    456.   FParameters.Assign(AValue);
    457. end;
    458.  
    459. procedure TProcess.SetProcessOptions(const Value: TProcessOptions);
    460. begin
    461.   FProcessOptions := Value;
    462.   If poNewConsole in FProcessOptions then
    463.     Exclude(FProcessOptions,poNoConsole);
    464.   if poRunSuspended in FProcessOptions then
    465.     Exclude(FProcessOptions,poWaitOnExit);
    466. end;
    467.  
    468. Const
    469.   READ_BYTES = 65536; // not too small to avoid fragmentation when reading large files.
    470.  
    471. function internalRuncommand(p:TProcess;out outputstring: ansistring;
    472.                            out exitstatus:integer):integer;
    473. var
    474.   numbytes,bytesread : integer;
    475. begin
    476.   result:=0;
    477.   bytesread:=0;
    478. try
    479.   p.Options := p.Options + [poUsePipes];
    480.   p.Execute;
    481.   while p.Running do
    482.   begin
    483.     Setlength(outputstring, READ_BYTES);
    484.     NumBytes := p.Output.Read(outputstring[1+bytesread], 255);
    485.   if NumBytes > 0 then
    486.     Inc(BytesRead, NumBytes);
    487.   end;
    488.   exitstatus:= p.exitstatus;
    489. finally
    490.   p.free;
    491. end;
    492. end;
    493.  
    494. Const
    495.   ForbiddenOptions = [poRunSuspended,poWaitOnExit];
    496.  
    497. function RunCommandIndir(const curdir: string; const exename: string; const commands:array of string; out outputstring: ansistring;out exitstatus:integer; Options : TProcessOptions = []):integer;
    498. Var
    499.     p : TProcess;
    500.     i : integer;
    501. begin
    502.   p:=TProcess.create(nil);
    503.   if Options<>[] then
    504.     P.Options:=Options - ForbiddenOptions;
    505.   p.Executable:=exename;
    506.   if curdir<>'' then
    507.     p.CurrentDirectory:=curdir;
    508.   if high(commands)>=0 then
    509.    for i:=low(commands) to high(commands) do
    510.      p.Parameters.add(commands[i]);
    511.   result:=internalruncommand(p,outputstring,exitstatus);
    512. end;
    513.  
    514. function RunCommand(const exename:string; const commands:array of string; out outputstring: ansistring; Options : TProcessOptions = []):boolean;
    515. Var
    516.     p : TProcess;
    517.     i,
    518.     exitstatus : integer;
    519. begin
    520.   p:=TProcess.create(nil);
    521.   if Options<>[] then
    522.     P.Options:=Options - ForbiddenOptions;
    523.   p.Executable:=exename;
    524.   if high(commands)>=0 then
    525.    for i:=low(commands) to high(commands) do
    526.      p.Parameters.add(commands[i]);
    527.   result:=internalruncommand(p,outputstring,exitstatus)=0;
    528.   if exitstatus<>0 then result:=false;
    529. end;
    530.  
    531. end.
    программа
    Код (Delphi):
    1. unit Unit1;
    2.  
    3. interface
    4.  
    5. uses
    6.   Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
    7.   Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
    8.  
    9. type
    10.   TForm1 = class(TForm)
    11.     Memo1: TMemo;
    12.     Button1: TButton;
    13.     procedure Button1Click(Sender: TObject);
    14.   private
    15.     { Private declarations }
    16.   public
    17.     { Public declarations }
    18.   end;
    19.  
    20. var
    21.   Form1: TForm1;
    22.  
    23. implementation
    24.  
    25. {$R *.dfm}
    26.  
    27. uses dprocess;  // this is the TProcess unit from FPC, now ported to delphi
    28.  
    29. procedure OutLn(s: string); overload;
    30. begin
    31.   form1.memo1.lines.add(s);
    32. end;
    33.  
    34. procedure OutLn(s: string; i: integer); overload;
    35. begin
    36.   outln(s + inttostr(i));
    37. end;
    38.  
    39. function RunProcess(const Binary: string; args: TStrings): boolean;
    40. const
    41.   BufSize = 1024;
    42. var
    43.   p: TProcess;
    44.   Buf: ansistring;
    45.   Count: integer;
    46.   i: integer;
    47.   LineStart: integer;
    48.   OutputLine: ansistring;
    49. begin
    50.   p := TProcess.Create(nil);
    51.   try
    52.     p.Executable := Binary;
    53.  
    54.     p.Options := [poUsePipes,
    55.                   poStdErrToOutPut];
    56.     p.ShowWindow := swoHIDE {ShowNormal};
    57.  
    58.     p.Parameters.Assign(args);
    59.     p.Execute;
    60.  
    61.     { Now process the output }
    62.     OutputLine:='';
    63.     SetLength(Buf,BufSize);
    64.     repeat
    65.       if (p.Output<>nil) then
    66.       begin
    67.         Count:=p.Output.Read(pansichar(Buf)^, BufSize);
    68.       end
    69.       else
    70.         Count:=0;
    71.       LineStart:=1;
    72.       i:=1;
    73.       while i<=Count do
    74.       begin
    75.         if CharInSet(Buf[i], [#10,#13]) then
    76.         begin
    77.           OutputLine:=OutputLine+Copy(Buf,LineStart,i-LineStart);
    78.           outln(String(OutputLine));
    79.           OutputLine:='';
    80.           if (i<Count) and (CharInset(Buf[i], [#10,#13])) and (Buf[i]<>Buf[i+1]) then
    81.             inc(i);
    82.           LineStart:=i+1;
    83.         end;
    84.         inc(i);
    85.       end;
    86.       OutputLine:=Copy(Buf,LineStart,Count-LineStart+1);
    87.     until Count=0;
    88.     if OutputLine <> '' then
    89.       outln(String(OutputLine));
    90.     p.WaitOnExit;
    91.     Result := p.ExitStatus = 0;
    92.     if not Result then
    93.       outln('Command '+ p.Executable +' failed with exit code: ', p.ExitStatus);
    94.   finally
    95.     FreeAndNil(p);
    96.   end;
    97. end;
    98.  
    99. const
    100.   prog = 'rz';
    101.  
    102. var args: TStringList;
    103.  
    104. procedure SetArgs;
    105. begin
    106.   args.add('e');
    107.   args.add('-r');
    108.   args.add('-y');
    109.   args.add('data.rz');
    110.   args.add('*');
    111. end;
    112.  
    113. procedure TForm1.Button1Click(Sender: TObject);
    114. begin
    115.   args := TStringList.Create;
    116.   SetArgs;
    117.   RunProcess(prog, args);
    118.   args.free; args := nil;
    119. end;
    120.  
    121. end.
     

    Вложения:

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

    Регистрация:
    26 июн 2011
    Сообщения:
    1.329
    Симпатии:
    867
    как я понял у 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.329
    Симпатии:
    867
    Правленый 1-ый код. Слишком велика разница по весу конечного приложения 26 против ~960 кб.
    Код (Delphi):
    1.  
    2. library Project5;
    3. const
    4.   user32    = 'user32.dll';
    5.   kernel32  = 'kernel32.dll';
    6. type
    7.   HWND = NativeUInt;
    8.   UINT = LongWord;
    9.   WPARAM = NativeUInt;
    10.   LPARAM = NativeInt;
    11.   DWORD = LongWord;
    12.   BOOL = LongBool;
    13.   LPCWSTR = PWideChar;
    14.   TPoint = record
    15.     X: Longint;
    16.     Y: Longint;
    17.   end;
    18.   TMsg = record
    19.     hwnd: HWND;
    20.     message: UINT;
    21.     wParam: WPARAM;
    22.     lParam: LPARAM;
    23.     time: DWORD;
    24.     pt: TPoint;
    25.   end;
    26. var
    27.   hReadPipe : THandle=0;
    28.   ReaderHandle : THandle=0;
    29.  
    30. function PeekMessage(var lpMsg: TMsg; hWnd: HWND; wMsgFilterMin, wMsgFilterMax, wRemoveMsg: UINT): BOOL; stdcall; external user32 name 'PeekMessageW';
    31. function TranslateMessage(const lpMsg: TMsg): BOOL; stdcall; external user32 name 'TranslateMessage';
    32. function DispatchMessage(const lpMsg: TMsg): BOOL; stdcall; external user32 name 'DispatchMessageW';
    33.  
    34. procedure Application_ProcessMessages;
    35. var
    36.   Msg: TMsg;
    37.   begin
    38.   while PeekMessage(Msg, 0, 0, 0, 1) do begin
    39.     TranslateMessage(Msg);
    40.     DispatchMessage(Msg);
    41.   end;
    42. end;
    43.  
    44. function ExtractFilePath(Files: String): String; var N: Integer; S:String;
    45. begin
    46.   S:= Files;
    47. if S[Length(S)]='\' then
    48.   Delete(S,Length(S),1);
    49.   N:= Pos('\',S);
    50. while N > 0 do begin
    51.   S:= Copy(S,N+1,Length(S)-N);
    52.   N:= Pos('\',S);
    53. end;
    54.   Result:= Copy(Files, 0, Length(Files)-Length(S));
    55. end;
    56.  
    57. type
    58.   TSysCharSet = set of AnsiChar;
    59.  
    60. function CharInSet(C: AnsiChar; const CharSet: TSysCharSet): Boolean;
    61. begin
    62.  Result := C in CharSet;
    63. end;
    64.  
    65. type
    66.   ThreadParams = record
    67.     hReadPipe : THandle;
    68.     s : String;
    69.   end;
    70.   PThreadParams = ^ThreadParams;
    71. var
    72.   Count: integer=0;
    73.   tmpline: AnsiString='';
    74.   line :  array [0..$FFFF] of AnsiString; // Size lines
    75.  
    76. function progressFullLineStr(l: integer): AnsiString; stdcall;
    77. begin
    78.   Result:= '';
    79. if Count<>0 then
    80.   Result:= line[l];
    81. end;
    82.  
    83. function progressFullLineCount: Integer; stdcall;
    84. begin
    85.   Result:= Count-1;
    86. end;
    87.  
    88. type
    89.   POverlapped = ^TOverlapped;
    90.   _OVERLAPPED = record
    91.     Internal: NativeUInt;
    92.     InternalHigh: NativeUInt;
    93.     Offset: DWORD;
    94.     OffsetHigh: DWORD;
    95.     hEvent: THandle;
    96.   end;
    97.   {$EXTERNALSYM _OVERLAPPED}
    98.   TOverlapped = _OVERLAPPED;
    99.   OVERLAPPED = _OVERLAPPED;
    100.   {$EXTERNALSYM OVERLAPPED}
    101.   PSecurityAttributes = ^TSecurityAttributes;
    102.   _SECURITY_ATTRIBUTES = record
    103.     nLength: DWORD;
    104.     lpSecurityDescriptor: Pointer;
    105.     bInheritHandle: BOOL;
    106.   end;
    107.   {$EXTERNALSYM _SECURITY_ATTRIBUTES}
    108.   TSecurityAttributes = _SECURITY_ATTRIBUTES;
    109.   SECURITY_ATTRIBUTES = _SECURITY_ATTRIBUTES;
    110.   {$EXTERNALSYM SECURITY_ATTRIBUTES}
    111.   PProcessInformation = ^TProcessInformation;
    112.   _PROCESS_INFORMATION = record
    113.     hProcess: THandle;
    114.     hThread: THandle;
    115.     dwProcessId: DWORD;
    116.     dwThreadId: DWORD;
    117.   end;
    118.   {$EXTERNALSYM _PROCESS_INFORMATION}
    119.   TProcessInformation = _PROCESS_INFORMATION;
    120.   PROCESS_INFORMATION = _PROCESS_INFORMATION;
    121.   {$EXTERNALSYM PROCESS_INFORMATION}
    122.   _STARTUPINFOW = record
    123.     cb: DWORD;
    124.     lpReserved: PWideChar;
    125.     lpDesktop: PWideChar;
    126.     lpTitle: PWideChar;
    127.     dwX: DWORD;
    128.     dwY: DWORD;
    129.     dwXSize: DWORD;
    130.     dwYSize: DWORD;
    131.     dwXCountChars: DWORD;
    132.     dwYCountChars: DWORD;
    133.     dwFillAttribute: DWORD;
    134.     dwFlags: DWORD;
    135.     wShowWindow: Word;
    136.     cbReserved2: Word;
    137.     lpReserved2: PByte;
    138.     hStdInput: THandle;
    139.     hStdOutput: THandle;
    140.     hStdError: THandle;
    141.   end;
    142.   TStartupInfo = _STARTUPINFOW;
    143.  
    144. function ReadFile(hFile: THandle; var Buffer; nNumberOfBytesToRead: DWORD; var lpNumberOfBytesRead: DWORD; lpOverlapped: POverlapped): BOOL; stdcall; external kernel32 name 'ReadFile';
    145.  
    146. function ThreadRead(Info : PThreadParams):Dword; stdcall;
    147. var
    148.   Buffer :  array [0..$FFFF] of AnsiChar;
    149.   nb: DWord;
    150.   i: Longint;
    151. begin
    152.   Info^.s:= '';
    153.   Result := 0;
    154. while ReadFile(Info^.hReadPipe,  buffer,  SizeOf(buffer),  nb,  nil) do
    155. begin
    156.   if nb = 0 then
    157.     Break;
    158.   for i:=0 to nb-1 do
    159.   begin
    160.   if CharInSet(buffer[i], ['A'..'Z', 'a'..'z', '0'..'9', '.', ' ', '%', ',', '.', '!', '&', '?', '@', '*', '/', '\', '-', '_', '=', '+', '#', '$', '№', '~', ';', '^', ':', ')', '(']) then
    161.     tmpline := tmpline + buffer[i];
    162.   end;
    163.     line[Count]:= tmpline;
    164.     tmpline:= '';
    165.     Count:= Count+1;
    166. end;
    167. if Count<>0 then
    168.   Result := 1;
    169. //   for l:=0 to Count-1 do
    170. //   Info^.s:= Info^.s + #13#10 + line[l];
    171. end;
    172.  
    173. Const
    174.   PipeBufSize = 1024;
    175.   MB_ICONERROR = $00000010;
    176.   STARTF_USESHOWWINDOW = 1;
    177.   STARTF_USESTDHANDLES = $100;
    178.   SW_HIDE = 0;
    179.   SW_SHOWNORMAL = 1;
    180.   WAIT_TIMEOUT = $00000102;
    181. var
    182.   FRunning : Boolean;
    183.   StartInfo: TStartupInfo;
    184.   ProcInfo: TProcessInformation;
    185.  
    186. function CreatePipe(var hReadPipe, hWritePipe: THandle; lpPipeAttributes: PSecurityAttributes; nSize: DWORD): BOOL; stdcall; external kernel32 name 'CreatePipe';
    187. function MessageBox(hWnd: HWND; lpText, lpCaption: PWideChar; uType: UINT): Integer; stdcall; external user32 name 'MessageBoxW';
    188.  
    189. procedure ZeroMemory(Destination: Pointer; Length: NativeUInt);
    190. begin
    191.   FillChar(Destination^, Length, 0);
    192. end;
    193.  
    194. function CreateThread(lpThreadAttributes: Pointer; dwStackSize: NativeUInt; lpStartAddress: Pointer; lpParameter: Pointer; dwCreationFlags: DWORD; var lpThreadId: DWORD): THandle; stdcall; external kernel32 name 'CreateThread';
    195. function TerminateThread(hThread: THandle; dwExitCode: DWORD): BOOL; stdcall; external kernel32 name 'TerminateThread';
    196. 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';
    197. function CloseHandle(hObject: THandle): BOOL; stdcall; external kernel32 name 'CloseHandle';
    198. function TerminateProcess(hProcess: THandle; uExitCode: UINT): BOOL; stdcall; external kernel32 name 'TerminateProcess';
    199. function WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD; stdcall; external kernel32 name 'WaitForSingleObject';
    200.  
    201. procedure ISExtract(const FileName, CmdParams: string; CmdPipe, ShowCmd: boolean; Priority: integer); stdcall;
    202. var
    203.   hWritePipe: THandle;
    204.   saPipe: TSecurityAttributes;
    205.   Params : ThreadParams;
    206.   ReaderID : Dword;
    207.   CmdLine: String;
    208. begin
    209.   CmdLine := '"' + FileName + '" ' + CmdParams;
    210. if CmdPipe then
    211. begin
    212.   saPipe.bInheritHandle := True;
    213.   saPipe.lpSecurityDescriptor := nil;
    214.   saPipe.nLength := SizeOf(saPipe);
    215.   if not CreatePipe(hReadPipe,hWritePipe, @saPipe, PipeBufSize) then
    216.     Messagebox(0, 'Error!','', MB_ICONERROR);
    217. end;
    218.   ZeroMemory(@StartInfo, SizeOf(StartInfo));
    219.   StartInfo.cb := SizeOf(StartInfo);
    220. if CmdPipe then
    221. begin
    222.   StartInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
    223.   StartInfo.hStdInput := hWritePipe;
    224.   StartInfo.hStdOutput := hWritePipe;
    225.   StartInfo.hStdError:= hWritePipe;
    226. end else
    227.   StartInfo.dwFlags := STARTF_USESHOWWINDOW;
    228. if ShowCmd then
    229.   StartInfo.wShowWindow := SW_SHOWNORMAL
    230.   else
    231.   StartInfo.wShowWindow := SW_HIDE;
    232. try
    233. if CmdPipe then
    234. begin
    235.   Params.hReadPipe := hReadPipe;
    236.   ReaderHandle := CreateThread( nil,
    237.                                 0,
    238.                                 @ThreadRead,
    239.                                 @Params,
    240.                                 0,
    241.                                 ReaderId);
    242.   if ReaderHandle = 0 then
    243.   begin
    244.     Messagebox(0, 'Error!','', MB_ICONERROR);
    245.     TerminateThread(ReaderHandle,0);
    246.   end;
    247. end;
    248.   if CreateProcess(nil,
    249.                    PChar(cmdline),
    250.                    nil,
    251.                    nil,
    252.                    true,
    253.                    Priority,
    254.                    nil,
    255.                    nil,
    256.                    StartInfo,
    257.                    ProcInfo) then
    258.     begin
    259.       FRunning:= True;
    260.       CloseHandle(ProcInfo.hThread);
    261.     if CmdPipe then
    262.       CloseHandle(hWritePipe);
    263.     end
    264.   else begin
    265.     Messagebox(0, 'Error!','', MB_ICONERROR);
    266.   if CmdPipe then
    267.     TerminateThread(ReaderHandle,0);
    268.     TerminateProcess(ProcInfo.hProcess, 1);
    269.   end;
    270.   repeat
    271.     Application_ProcessMessages;
    272.   until WaitforSingleObject(ProcInfo.hProcess, 50) <> WAIT_TIMEOUT;
    273.   finally
    274.     if ProcInfo.hProcess > 0 then
    275.        CloseHandle(ProcInfo.hProcess);
    276.     if hReadPipe > 0 then
    277.        CloseHandle(hReadPipe);
    278.     if ReaderHandle > 0 then
    279.        CloseHandle(ReaderHandle);
    280.   end;
    281. end;
    282.  
    283. function ISProcessStatus: Dword; stdcall;
    284. begin
    285. if FRunning then
    286.   Result:= WaitforSingleObject(ProcInfo.hProcess, 50)
    287. else
    288.   Result:= 0;
    289. end;
    290.  
    291. const
    292.   WM_CLOSE = $10;
    293.  
    294. function FindWindowEx(Parent, Child: HWND; ClassName, WindowName: LPCWSTR): HWND; stdcall; external user32 name 'FindWindowExW';
    295. function GetWindowThreadProcessId(hWnd: HWND; lpdwProcessId: Pointer = nil): DWORD; stdcall; overload; external user32 name 'GetWindowThreadProcessId';
    296. function PostMessage(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): BOOL; stdcall; external user32 name 'PostMessageW';
    297.  
    298. procedure ISProcessClose; stdcall;
    299. var
    300.   h: HWND;
    301.   pid: DWord;
    302. begin
    303.   if FRunning then
    304.   begin
    305.     h := FindWindowEx(0, 0, nil, nil);
    306.     while (h <> 0) do
    307.     begin
    308.       GetWindowThreadProcessId(h, @pid);
    309.     if (pid = ProcInfo.dwProcessId) then
    310.       PostMessage(h,WM_CLOSE,0,0);
    311.       h := FindWindowEx(0, h, nil, nil);
    312.     end;
    313.   end;
    314. end;
    315.  
    316. exports
    317.   ISExtract,
    318.   progressFullLineStr, progressFullLineCount,
    319.   ISProcessStatus, ISProcessClose;
    320. begin
    321. end.
    322.  
     
    Последнее редактирование: 27 сен 2018

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