Surveiller l'execution d'un programme externe

**Gouyon** · 28/01/2019, 15h29

Bonjour

J'ai un exécutable de type console qui réalise des calculs et qui à chaque étape de calcul terminée imprime sur l'écran une information du type #PROG xx (où xx représente un nombre entre 0 et 100)

Après quelque recherche j'ai trouvé ce code qui me permet d'exécuter mon programme de calcul.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
 
procedure TForm1.exec;
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  CommandLine: {$IFDEF UNICODE}WideString{$ELSE}string{$ENDIF};
 
begin
  CommandLine := '"calcullong.exe"';
 
  ZeroMemory(@StartupInfo, SizeOf(StartupInfo));
  StartupInfo.cb := SizeOf(StartupInfo);
 
  if CreateProcess(nil, PChar(CommandLine), nil, nil, FALSE, 0, nil, nil, StartupInfo, ProcessInfo) then
  begin
    repeat
      Application.ProcessMessages;
    until WaitForSingleObject(ProcessInfo.hProcess, 200) <> WAIT_TIMEOUT;
 
    CloseHandle(ProcessInfo.hProcess);
    CloseHandle(ProcessInfo.hThread);
  end
  else RaiseLastOSError;
end;

J'aimerai savoir maintenant comment je peux récupérer les information de progression qui sont envoyé par le programme de calcul.

Je me doute qu'il faille mettre une instruction dans cette boucle mais je n'ai pas trouvé laquelle.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
 
    repeat
      Application.ProcessMessages;
      //récupération des info de progression
 
    until WaitForSingleObject(ProcessInfo.hProcess, 200) <> WAIT_TIMEOUT;

Si vous avez des idées je suis preneur

**ShaiLeTroll** · 28/01/2019, 18h16

Je n'ai jamais testé avec du texte qui change comme UPX par exemple mais uniquement avec du texte qui s'ajoute

CreateProcess + Pipes

**Gouyon** · 29/01/2019, 08h06

Je vais tester.
Par contre dans le code que tu donnes à quoi correspond TSLTShellExecuteWrapperCallCmdEvent

**Gouyon** · 29/01/2019, 10h31

Après un test ça fonctionne bien et je l'ai adapté pour qu'il affiche une barre de progression sur mon interface

Pour ceux que ça intéresse je vous livre cette adaptation.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
 
unit ShellExecuteWrapper;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.ComCtrls;
 
type
  TSLTShellExecuteWrapper = class
  private
    progBar: TProgressBar;
  public
    constructor Create(prgB: TProgressBar);
    function CallCmd(const CmdDirectory, CmdName, CmdParam: string;
      out ExitCode: Int64; out ErrorText: string; Delay: Cardinal = INFINITE;
      PipeMaxSize: Cardinal = 0): Boolean;
  end;
 
implementation
{ * -----------------------------------------------------------------------------
  le constructeur prend en paramètre l'objet barre de progression figurant dans l'interface
  @param prgB barre de progression figurant dans l'interface
----------------------------------------------------}
 
constructor TSLTShellExecuteWrapper.Create(prgB: TProgressBar);
begin
  progBar := prgB;
end;
 
{ * -----------------------------------------------------------------------------
  la fonction CallCmd permet de lancer un programme console, tout en récupérant en quasi temps-réel le contenu devant normalement s'y afficher
  @param CmdDirectory Dossier contenant le Fichier CmdName
  @param CmdName programme console à executer
  @param CmdParam paramètres de la ligne de commande
  @param ExitCode Code de Sortie renvoyé par le programme console, -1 si non récupéré
  @param ErrorText chaine contenant tout ce qui a été signalé comme erreurs (canal erreur)
  @param Delay indique le temps entre chaque cycle de lecture des canaux, détermine la fréquence de lancement de WaitEvent, par défaut, cela attend que le programme console se termine
  @param PipeMaxSize défini la taille maximal que l'on lit à chaque chaque cycle de lecture des canaux, si zéro, taille non limitée par défaut
  @return Indique si le programme a été lancé
  ------------------------------------------------------------------------------ }
function TSLTShellExecuteWrapper.CallCmd(const CmdDirectory, CmdName,
  CmdParam: string; out ExitCode: Int64; out ErrorText: string;
  Delay: Cardinal = INFINITE; PipeMaxSize: Cardinal = 0): Boolean;
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  CmdLine: string; // utile pour le débogage
  SecurityAttr: TSecurityAttributes;
  hReadPipeInput, hWritePipeInput: NativeUInt;
  hReadPipeOutput, hWritePipeOutput: NativeUInt;
  hReadPipeError, hWritePipeError: NativeUInt;
  lpCurrentDirectory: PChar;
  Terminated: Boolean;
  AbortProcess: Boolean;
  HandleFunctionProcess: Cardinal;
  OutText: string;
 
  function ReadPipe(Handle: Cardinal; out Buf: string): Boolean;
  const
    MAX_INT: Cardinal = MaxInt;
  var
    PipeSize: Cardinal;
    PipeToRead, PipeReaded: Cardinal;
    PipeBuf: array of AnsiChar;
    AnsiBuf: AnsiString;
  begin
    PipeSize := GetFileSize(Handle, nil);
    // On oublie si cela dépasse 2Go ... normalement c'est 4Ko
    if (PipeMaxSize > 0) and (PipeSize > PipeMaxSize) then
      PipeToRead := PipeMaxSize
    else
      PipeToRead := PipeSize;
 
    Result := PipeToRead > 0;
    if Result then
    begin
      SetLength(PipeBuf, PipeToRead);
      ZeroMemory(@PipeBuf[0], PipeToRead);
      ReadFile(Handle, PipeBuf[0], PipeToRead, PipeReaded, nil);
 
      SetLength(AnsiBuf, PipeToRead);
      OemToAnsi(@PipeBuf[0], @AnsiBuf[1]);
      Buf := string(AnsiBuf);
    end;
  end;
 
  procedure ReadPipes();
  var
    DeltaOutputText: string;
    DeltaErrorText: string;
    sub: string;
    x, nombre, code: integer;
  begin
    if ReadPipe(hReadPipeOutput, DeltaOutputText) then
    begin
      if DeltaOutputText <> '' then
      begin
        OutText := OutText + DeltaOutputText;
        x := Pos('#PROGRESS ', OutText);
        while x > 0 do
        begin
          delete(OutText, 1, x + length('#PROGRESS ') - 1);
          x := Pos(char(13) + char(10), OutText);
          sub := copy(OutText, 1, x - 1);
          val(sub, nombre, code);
          if (code = 0) then
            begin
              progBar.Position:=nombre;
            end;
            x := Pos('#PROGRESS ', OutText);
        end;
 
      end;
    end;
 
    if ReadPipe(hReadPipeError, DeltaErrorText) then
      ErrorText := ErrorText + DeltaErrorText;
 
  end;
 
begin
  (*
    Result := True;
    OutputText := 'Dummy Output';
    ErrorText := 'Dummy Error';
    ErrorCode := 0;
    Exit;
  *)
  OutText := '';
  ErrorText := '';
  try
    SecurityAttr.nLength := SizeOf(TSecurityAttributes);
    SecurityAttr.lpSecurityDescriptor := nil;
    SecurityAttr.bInheritHandle := True;
    if CreatePipe(hReadPipeInput, hWritePipeInput, @SecurityAttr, 0) and
      CreatePipe(hReadPipeOutput, hWritePipeOutput, @SecurityAttr, 0) and
      CreatePipe(hReadPipeError, hWritePipeError, @SecurityAttr, 0) then
    begin
      try
        ZeroMemory(@StartupInfo, SizeOf(StartupInfo));
        // GetStartupInfo(StartupInfo);
        StartupInfo.cb := SizeOf(StartupInfo);
        StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
        // Active wShowWindow et hStdOutput/hStdError
        StartupInfo.wShowWindow := SW_HIDE;
        StartupInfo.hStdInput := hReadPipeInput;
        StartupInfo.hStdOutput := hWritePipeOutput;
        StartupInfo.hStdError := hWritePipeError;
        ZeroMemory(@ProcessInfo, SizeOf(ProcessInfo));
 
        if CmdDirectory <> '' then
        begin
          CmdLine := Format('"%s%s" %s',
            [IncludeTrailingPathDelimiter(CmdDirectory), CmdName, CmdParam]);
          lpCurrentDirectory := PChar(CmdDirectory);
        end
        else
        begin
          CmdLine := Format('%s %s', [CmdName, CmdParam]);
          lpCurrentDirectory := nil;
        end;
 
        Result := CreateProcess(nil, PChar(CmdLine), @SecurityAttr,
          @SecurityAttr, True, 0, nil, lpCurrentDirectory, StartupInfo,
          ProcessInfo);
        if Result then
        begin
          try
            Terminated := False;
            AbortProcess := False;
            while not Terminated do
            begin
              case WaitForSingleObject(ProcessInfo.hProcess, Delay) of
                WAIT_OBJECT_0:
                  begin
                    ReadPipes();
                    Terminated := True;
                  end;
                WAIT_ABANDONED:
                  Terminated := True;
                WAIT_TIMEOUT:
                  begin
                    ReadPipes();
                    Terminated := Delay = INFINITE;
                  end;
                WAIT_FAILED:
                  Abort;
              else
                Terminated := True;
              end;
 
              if AbortProcess then
              begin
                HandleFunctionProcess := OpenProcess(PROCESS_TERMINATE, False,
                  ProcessInfo.dwProcessId);
                if HandleFunctionProcess > 0 then
                begin
                  TerminateProcess(HandleFunctionProcess, 0);
                  CloseHandle(HandleFunctionProcess);
                end;
              end;
            end;
 
            TULargeInteger(ExitCode).HighPart := 0;
            if not GetExitCodeProcess(ProcessInfo.hProcess,
              TULargeInteger(ExitCode).LowPart) then
              ExitCode := -1;
          finally
            CloseHandle(ProcessInfo.hThread);
            CloseHandle(ProcessInfo.hProcess);
            // The handles for both the process and the main thread must be closed through calls to CloseHandle
          end;
        end;
      finally
        CloseHandle(hReadPipeInput);
        CloseHandle(hWritePipeInput);
        CloseHandle(hReadPipeOutput);
        CloseHandle(hWritePipeOutput);
        CloseHandle(hReadPipeError);
        CloseHandle(hWritePipeError);
      end;
    end
    else
      raise Exception.Create('Impossible de créer les Pipes');
  except
    on E: Exception do
    begin
      OutputDebugString(PChar(Format('%s.CallCmd Error %s, Message : %s',
        [Self.ClassName(), E.ClassName(), E.Message])));
      raise;
    end;
  end;
end;
end.

Et voici comment se fait l'appel dans la fenêtre principale

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
 
procedure TForm1.btnExeClick(Sender: TObject);
 
var
  ExitCode: Int64;
  outTxt, ErrorText: string;
  wrp: TSLTShellExecuteWrapper;
begin
  wrp := TSLTShellExecuteWrapper.Create(progBar);
  wrp.CallCmd('D:\Projets\C++\calcullong\Debug', 'calcullong.exe', '', ExitCode, ErrorText, 10, 256);
end;

ATTENTION
Si jamais c'est vous qui avez écrit le code externe à exécuter pensez bien à faire un flush juste après que vous ayez envoyé le message de progression (#PROGRESS xx dans mon cas).
En effet si vos messages sont relativement petit le buffer de sortie va se remplir et vous ne le lirez jamais pendant l'exécution. Ce n'est qu'une fois l’exécution terminée que vous aurez tout en un seul paquet.
Je me suis fait assez souvent piégé avec ça.

Un petit exemple en C

Code C :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
 
int main()
{
	printf("#DEBUT\n");
	for (int n = 0; n < 100; n++)
	{
		double tmp = 4*(double)rand()/RAND_MAX+ 4 * (double)rand() / RAND_MAX+1;		
		::Sleep(tmp * 200);
		printf("#PROGRESS %d\n", n+1);
		_flushall();// vidage du buffer de sortie indispensable
		std::cout << "Hello World!\n";
	}
	printf("#FIN\n");
}

**guillemouze** · 30/01/2019, 09h30

Envoyé par Gouyon

ATTENTION
[I]Si jamais c'est vous qui avez écrit le code externe à exécuter pensez bien à faire un flush juste après que vous ayez envoyé le message de progression (#PROGRESS xx dans mon cas).
En effet si vos messages sont relativement petit le buffer de sortie va se remplir et vous ne le lirez jamais pendant l'exécution. Ce n'est qu'une fois l’exécution terminée que vous aurez tout en un seul paquet.

Petite astuce, le endl ajoute une fin de ligne et flush le stream, donc cout << "Hello World!" << endl; flushera le buffer

**ShaiLeTroll** · 30/01/2019, 18h18

Envoyé par Gouyon

Je vais tester.
Par contre dans le code que tu donnes à quoi correspond TSLTShellExecuteWrapperCallCmdEvent

Il y en a un tas de version de SLT.Common.Winapi.ShellApi.pas qui traine sur le forum, celle-ci est complète : Attendre la fin d’exécution d'un programme externe

Sympa ton adaptation, je m'amuserais à fait un Wrapper à UPX pour tester un affichage Graphique comme le tien

Surveiller l'execution d'un programme externe

API, COM et SDKs Delphi

Vue hybride

Discussions similaires

Partager

Partager