Commande DOS affichée dans memo, le tout dans un thread

**ShaiLeTroll** · 09/10/2013, 17h19

Oui Self ne passe passe du tout, j'ai encoré été trop vite, l'habitude du C++ et de son absence de rigueur sur les types pointeurs et int

Code :

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

CallCmd(prvtDirectory, 'cmd.exe', '/C '+prvtCommand, ExitCode, OutputText, ErrorText, 100,  NativeUInt(Self), _TThreadDosCommandWaitEvent);

Change Parent: Cardinal en Parent: NativeUInt !
Pour gérer 32 et 64 bits sans soucis !

Ne prend surtout pas le Handle, cela sera une belle Violation d'Access sur le transtypage sauvage dans "_TThreadDosCommandWaitEvent"

Envoyé par LaurentC33

1 - Tu me dis que "_TThreadDosCommandWaitEvent" doit être déclaré avant, tu veux dire que dans "implementation" elle doit être positionnée avant
?

Si tu déclares "_TThreadDosCommandWaitEvent" dans interface comme tu l'as fait, cela n'a plus aucune importance !

Si tu NE déclares PAS dans interface, cela laissera cette fonction privée dans ton unit mais oblige de mettre "_TThreadDosCommandWaitEvent avant le Execute !

Envoyé par LaurentC33

2 - Je suis obligé d'utiliser CallCmd dans un thread ?

tout dépend ton besoin,
si ton programme DOIT attendre le CMD, je dirais : NON !
si ton programme peut faire autre chose pendant ce temps, je dirais : OUI !

Ce n'est obligatoire, c'est juste une question confort pour l'utilisateur !

**LaurentC33** · 09/10/2013, 17h25

OKi j'envoi le Self.Handle donc

Vais essayer de faire tourner tout cela

Merci beaucoup je te tiens au courant !

**ShaiLeTroll** · 09/10/2013, 17h27

Envoyé par LaurentC33

OKi j'envoi le Self.Handle donc!

Hein ! Surtout pas !
Je sais que le cast NativeUInt(Self) est vilain mais permet de pouvoir mettre n'importe quoi !
Un pointeur sur un struct, une référence sur un objet ... mais il faut faire le cast reciproque équivalent
Avec Handle, tu ne pourras pas retrouver ton objet TThread sans gérer une liste de conversion !

**LaurentC33** · 09/10/2013, 17h39

Hum, rien en s’exécute, bizarre...

Le form qui fait office de test :

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
 
unit Unit7;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, threadEpcWindows;
 
type
  TForm7 = class(TForm)
    Memo1: TMemo;
    procedure FormShow(Sender: TObject);
 
  private
    { Déclarations privées }
  public
    { Déclarations publiques }
 
  end;
 
  procedure waitCallBack(const Output, Error: string; var AbortProcess: Boolean);
 
var
  Form7: TForm7;
 
implementation
 
{$R *.dfm}
 
procedure waitCallBack(const Output, Error: string; var AbortProcess: Boolean);
begin
  Form7.Memo1.Lines.Add(Output+Error);
end;
 
procedure TForm7.FormShow(Sender: TObject);
var
  dosThread: TThreadDosCommand;
begin
  dosThread := TThreadDosCommand.Create(True);
  dosThread.setCommand('', 'ipconfig', waitCallBack);
  dosThread.Resume;
end;
 
 
 
end.

Ma classe héritée TThread qui pilote ta classe :

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
 
unit threadEpcWindows;
 
{
 
Classe de contrôle des méthodes de l'unité epcWindows
 
Ex :
 
procedure waitCallBack(const Output, Error: string; var AbortProcess: Boolean);
begin
   Form.Memo.Lines.Add(Output);
end;
 
procedure TForm.FormShow(Sender: TObject);
var
  dosThread: TThreadDosCommand;
begin
  dosThread := TThreadDosCommand.Create(True);
  dosThread.setCommand('', 'ipconfig', waitCallBack);
  dosThread.Start;
end;
 
);
 
 
 
}
 
interface
 
uses System.Classes, epcWindows, VCL.Dialogs;
 
type
  TWaitEvent = procedure(const Output, Error: string; var AbortProcess: Boolean);
 
  TThreadDosCommand = class(TThread)
    private
      prvtDirectory, prvtCommand: string;
      prvtWaitEvent: TWaitEvent;
    public
      procedure setCommand(pDirectory, pCommand: string; pWaitEvent: TWaitEvent);
    protected
      procedure Execute; override;
  end;
 
 
procedure _TThreadDosCommandWaitEvent(Parent: NativeUInt; const Output, Error: string; var AbortProcess: Boolean); stdcall;
 
implementation
 
procedure _TThreadDosCommandWaitEvent(Parent: NativeUInt; const Output, Error: string; var AbortProcess: Boolean); stdcall;
begin
  if Parent > 0 then
  begin
    TThreadDosCommand(Parent).prvtWaitEvent(Output, Error, AbortProcess);
  end;
end;
 
{ TThreadCommand }
 
 
 
procedure TThreadDosCommand.setCommand(pDirectory, pCommand: string; pWaitEvent: TWaitEvent);
begin
  prvtDirectory := pDirectory;
  prvtCommand := pCommand;
  prvtWaitEvent := pWaitEvent;
end;
 
procedure TThreadDosCommand.Execute;
var
  ExitCode: Int64;
  OutputText: string;
  ErrorText: string;
begin
  inherited;
  CallCmd(prvtDirectory, 'cmd.exe', '/C '+prvtCommand, ExitCode, OutputText, ErrorText, 0,  Self.Handle, _TThreadDosCommandWaitEvent);
end;
 
end.

Et ta superbe classe :

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
 
unit epcWindows;
 
interface
 
uses Windows, SysUtils, VCL.Dialogs;
 
{* -----------------------------------------------------------------------------
TCallCmdEvent pointeur de procédure ...
@param Parent identifiant privé utilisé dans WaitEvent fourni par la fonction appelante de CallCmd
@param Output contiennent les derniers éléments envoyés par le programme console sur le canal StdOut
@param Error contiennent les derniers éléments envoyés par le programme console sur le canal StdError
@param AbortProcess indique si la processus doit être arrêté
------------------------------------------------------------------------------ }
type
  TCallCmdEvent = procedure(Parent: NativeUInt; const Output, Error: string; var AbortProcess: Boolean); stdcall;
 
function CallCmd(const CmdDirectory, CmdName, CmdParam: string; out ExitCode: Int64; out OutputText: string; out ErrorText: string; Delay: Cardinal = INFINITE; Parent: NativeUInt = 0; WaitEvent: TCallCmdEvent = nil; PipeMaxSize: Cardinal = 0): Boolean;
 
implementation
 
uses Math;
 
{* -----------------------------------------------------------------------------
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 OutputText chaine contenant tout ce qui aurait du s'afficher (canal sortie)
@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 Parent identifiant privé utilisé dans WaitEvent fourni par la fonction appelante de CallCmd
@param WaitEvent procédure à lancer lorsque le Delay est écoulé, Output et Error contiennent les derniers éléments envoyés par le programme console sur les canaux depuis le dernier délai, AbortProcess indique si la processus doit être arrêté
@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 CallCmd(const CmdDirectory, CmdName, CmdParam: string; out ExitCode: Int64; out OutputText: string; out ErrorText: string; Delay: Cardinal = INFINITE; Parent: NativeUInt = 0; WaitEvent: TCallCmdEvent = nil; PipeMaxSize: Cardinal = 0): Boolean;
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  CmdLine: string; // utile pour le débogage
  SecurityAttr : TSecurityAttributes;
  hReadPipeInput, hWritePipeInput: THandle;
  hReadPipeOutput, hWritePipeOutput: THandle;
  hReadPipeError, hWritePipeError: THandle;
  Terminated: Boolean;
  AbortProcess: Boolean;
  HandleFunctionProcess: Cardinal;
 
  function ReadPipe(Handle: Cardinal; out Buf: string): Boolean;
  const
    MAX_INT: Cardinal = MaxInt;
  var
    PipeSize: Cardinal;
    PipeToRead, PipeReaded: Cardinal;
  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(Buf, PipeToRead);
      ZeroMemory(@Buf[1], PipeToRead);
      ReadFile(Handle, Buf[1], PipeToRead, PipeReaded, nil);
    end;
  end;
 
  procedure ReadPipes();
  var
    DeltaOutputText: string;
    DeltaErrorText: string;
  begin
    if ReadPipe(hReadPipeOutput, DeltaOutputText) then
      OutputText := OutputText + DeltaOutputText;
    if ReadPipe(hReadPipeError, DeltaErrorText) then
      ErrorText := ErrorText + DeltaErrorText;
    try
      if Assigned(WaitEvent) then
        WaitEvent(Parent, DeltaOutputText, DeltaErrorText, AbortProcess);
    except
      on E: Exception do
        OutputDebugString(PChar(Format('epcWindows.CallCmd.ReadPipes.WaitEvent - "%s" : "%s"', [E.ClassName, E.Message])));
    end;
  end;
 
begin
  (*
  Result := True;
  OutputText := 'Dummy Output';
  ErrorText := 'Dummy Error';
  ErrorCode := 0;
  Exit;
  *)
 
  OutputText := '';
  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));
        CmdLine := Format('"%s%s" %s', [IncludeTrailingPathDelimiter(CmdDirectory), CmdName, CmdParam]);
        Result := CreateProcess(nil, PChar(CmdLine), @SecurityAttr, @SecurityAttr, True, 0, nil, PChar(CmdDirectory), 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('epcWindows.CallCmd Error %s, Message : %s', [E.ClassName, E.Message])));
      raise;
    end;
  end;
end;
 
end.

**LaurentC33** · 09/10/2013, 20h08

Désolé je n'avais pas vu ton message !

Il faut que je fasse la réciprocité de NativeUInt(Self) dans WaitEvent, c'est bien ça ?

Diantre compliqué tout cela

**ShaiLeTroll** · 10/10/2013, 10h02

Pour NativeUInt, oui pour Parent comme tu l'as fait !

Code :

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

1
2
3
4
5
6
7
procedure _TThreadDosCommandWaitEvent(Parent: NativeUInt; const Output, Error: string; var AbortProcess: Boolean); stdcall;
begin
  if Parent > 0 then
  begin
    TThreadDosCommand(Parent).prvtWaitEvent(Output, Error, AbortProcess);
  end;
end;

il faut appeler comme ceci

Code :

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

1
2
3
4
5
6
7
8
9
 
procedure TThreadDosCommand.Execute;
var
  ExitCode: Int64;
  OutputText: string;
  ErrorText: string;
begin
  CallCmd('', 'cmd.exe', '/C '+prvtCommand, ExitCode, OutputText, ErrorText, 0,  NativeUInt(Self), _TThreadDosCommandWaitEvent);
end;

Si tu utilises toujours 'cmd.exe', je te conseille de laisser le directory vide !
Ma fonction était conçu pour lancer n'importe quel exe dans un dossier non système

Evite Output+Error !
Même si le canal Error est souvent vide, il ne faut pas mélanger, leur contenu est différent !

inherited dans le Execute ne me semble pas raisonnable !
Execute est abstract ! cela m'étonne que tu n'aies pas une EAbstractError !

Sinon, ipconfig essaye de le lancer directement sans passer par CMD.EXE
Je pense que tu pourrais avoir ses Output ! Je n'ai pas vérifié mais cela me semble possible !

Fait attention l'utilisation d'un Memo depuis un TThread, cela pourrai parfois planter genre Violation d'Acces, Instruction Privilégié et autres délires de l'OS !

**LaurentC33** · 10/10/2013, 11h15

Bonjour Shai

Output+Error, t'inquiètes, c'est juste pour tester

Pour l'instant

Code :

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

1
2
 
Result := CreateProcess(nil, PChar(CmdLine), @SecurityAttr, @SecurityAttr, True, 0, nil, PChar(CmdDirectory), StartupInfo, ProcessInfo);

Result := false en permanence, j'essaye de comprendre pourquoi

Quand je debug "CreateProcess"
E2035 Pas assez de paramètres originaux

**LaurentC33** · 10/10/2013, 16h09

Impossible de faire fonctionner...Je ne comprends pas.

Voici le projet d'exemple

SI jamais tu as le temps d'y jeter un coup d'oeil (sans vouloir abuser) sinon c'est vraiment pas grave, je laisserais la première méthode que j'ai utilisé.

Dans tous les cas, tu m'a appris un paquet de trucs sur Delphi et je t'en remercie grandement

**ShaiLeTroll** · 11/10/2013, 13h54

Ma fonction était prévue pour un chemin complet de l'exe !

Si l'on appelle GetLastError(), il retourne 123 = ERROR_INVALID_NAME

J'ai corrigé le NativeUInt

Code :

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

1
2
3
4
begin
  CallCmd('', 'cmd.exe', '/C ' + prvtCommand, ExitCode, OutputText, ErrorText,
    0, NativeUInt(Self), _TThreadDosCommandWaitEvent);
end;

J'ai pour ma part améliorer CallCmd pour gérer automatiquement le cas spécial 'cmd.exe'

Ensuite, mon code était conçu Delphi 7 donc Ansi !
Je te suggère cette correction simpliste, juste le changement du Out de ReadPipe et les appels de ReadPipes concernant le mélange AnsiString, PChar et String

Voici le fichier complet fonctionnant sous XE2 :

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
unit epcWindows;
 
interface
 
uses Windows, SysUtils, VCL.Dialogs;
 
{ * -----------------------------------------------------------------------------
  TCallCmdEvent pointeur de procédure ...
  @param Parent identifiant privé utilisé dans WaitEvent fourni par la fonction appelante de CallCmd
  @param Output contiennent les derniers éléments envoyés par le programme console sur le canal StdOut
  @param Error contiennent les derniers éléments envoyés par le programme console sur le canal StdError
  @param AbortProcess indique si la processus doit être arrêté
  ------------------------------------------------------------------------------ }
type
  TCallCmdEvent = procedure(Parent: NativeUInt; const Output, Error: string;
    var AbortProcess: Boolean); stdcall;
 
function CallCmd(const CmdDirectory, CmdName, CmdParam: string;
  out ExitCode: Int64; out OutputText: string; out ErrorText: string;
  Delay: Cardinal = INFINITE; Parent: NativeUInt = 0;
  WaitEvent: TCallCmdEvent = nil; PipeMaxSize: Cardinal = 0): Boolean;
 
implementation
 
uses Math;
 
{ * -----------------------------------------------------------------------------
  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 OutputText chaine contenant tout ce qui aurait du s'afficher (canal sortie)
  @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 Parent identifiant privé utilisé dans WaitEvent fourni par la fonction appelante de CallCmd
  @param WaitEvent procédure à lancer lorsque le Delay est écoulé, Output et Error contiennent les derniers éléments envoyés par le programme console sur les canaux depuis le dernier délai, AbortProcess indique si la processus doit être arrêté
  @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 CallCmd(const CmdDirectory, CmdName, CmdParam: string;
  out ExitCode: Int64; out OutputText: string; out ErrorText: string;
  Delay: Cardinal = INFINITE; Parent: NativeUInt = 0;
  WaitEvent: TCallCmdEvent = nil; PipeMaxSize: Cardinal = 0): Boolean;
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  CmdLine: string; // utile pour le débogage
  WorkDir: string;
  SecurityAttr: TSecurityAttributes;
  hReadPipeInput, hWritePipeInput: THandle;
  hReadPipeOutput, hWritePipeOutput: THandle;
  hReadPipeError, hWritePipeError: THandle;
  Terminated: Boolean;
  AbortProcess: Boolean;
  HandleFunctionProcess: Cardinal;
 
  function ReadPipe(Handle: Cardinal; out Buf: AnsiString): Boolean;
  const
    MAX_INT: Cardinal = MaxInt;
  var
    PipeSize: Cardinal;
    PipeToRead, PipeReaded: Cardinal;
    BufOem: 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(BufOem, PipeToRead);
      ZeroMemory(@BufOem[1], PipeToRead);
      ReadFile(Handle, BufOem[1], PipeToRead, PipeReaded, nil);
 
      SetLength(Buf, PipeReaded);
      OemToCharA(@BufOem[1], @Buf[1])
    end;
  end;
 
  procedure ReadPipes();
  var
    DeltaOutputText: AnsiString;
    DeltaErrorText: AnsiString;
  begin
    if ReadPipe(hReadPipeOutput, DeltaOutputText) then
      OutputText := OutputText + string(DeltaOutputText);
    if ReadPipe(hReadPipeError, DeltaErrorText) then
      ErrorText := ErrorText + string(DeltaErrorText);
    try
      if Assigned(WaitEvent) then
        WaitEvent(Parent, string(DeltaOutputText), string(DeltaErrorText), AbortProcess);
    except
      on E: Exception do
        OutputDebugString
          (PChar(Format('epcWindows.CallCmd.ReadPipes.WaitEvent - "%s" : "%s"',
          [E.ClassName, E.Message])));
    end;
  end;
 
begin
  OutputText := '';
  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 SameText(CmdName, 'cmd.exe') then
        begin
          CmdLine := Format('%s %s', [System.SysUtils.GetEnvironmentVariable('COMSPEC'), CmdParam]);
          WorkDir := ExtractFileDir(System.SysUtils.GetEnvironmentVariable('COMSPEC'));
        end
        else
        begin
          CmdLine := Format('"%s%s" %s', [IncludeTrailingPathDelimiter(CmdDirectory), CmdName, CmdParam]);
          WorkDir := CmdDirectory;
        end;
 
        Result := CreateProcess(nil, PChar(CmdLine), @SecurityAttr,
          @SecurityAttr, True, 0, nil, PChar(WorkDir), 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('epcWindows.CallCmd Error %s, Message : %s',
        [E.ClassName, E.Message])));
      raise;
    end;
  end;
end;
 
end.

**LaurentC33** · 11/10/2013, 15h18

Bonjour Shai !

Merci beaucoup, OutputText me renvoi bien le retour, c'est nickel !
C'est ma classe de thread qui déconne maintenant à la ligne :

Code :

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

1
2
3
 
 
TThreadDosCommand(Parent).prvtWaitEvent(Output, Error, AbortProcess);

Parent est bien renseigné.
Par contre la méthode prvtWaitEvent renvoi l'erreur :
E2003 Identificateur non déclaré : 'prvtWaitEvent'

EDIT : Je suis un idiot, j'ai trouvé (NativeUInt(Self))
Ta classe fonctionne nickel, milles mercis pour ta (grande) patience !!

**LaurentC33** · 11/10/2013, 16h27

J'ai rajouté une méthode pour connaître quand le processus est terminé :

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
 
unit threadEpcWindows;
 
{
 
Classe de contrôle des méthodes de l'unité epcWindows
 
Ex :
 
 procedure waitCallBack(const Output, Error: string; var AbortProcess: Boolean);
begin
  Form.Memo.Lines.Add(Output);
end;
 
procedure TForm.FormShow(Sender: TObject);
var
  dosThread: TThreadDosCommand;
  command: string;
begin
  command := 'ipconfig';
  dosThread := TThreadDosCommand.Create(True);
  dosThread.setCommand(command, waitCallBack);
  dosThread.FreeOnTerminate := true;
  dosThread.Resume;
end;
 
 
);
 
 
 
}
 
interface
 
uses System.Classes, epcWindows, VCL.Dialogs;
 
type
  TWaitEvent = procedure(const Output, Error: string; var AbortProcess: Boolean; IsComplete: Boolean);
 
  TThreadDosCommand = class(TThread)
    private
      prvtCommand: string;
      prvtWaitEvent: TWaitEvent;
    public
      procedure setCommand(pCommand: string; pWaitEvent: TWaitEvent);
    protected
      procedure Execute; override;
  end;
 
 
procedure _TThreadDosCommandWaitEvent(Parent: NativeUInt; const Output, Error: string; var AbortProcess: Boolean; IsComplete: Boolean); stdcall;
 
implementation
 
procedure _TThreadDosCommandWaitEvent(Parent: NativeUInt; const Output, Error: string; var AbortProcess: Boolean; IsComplete: Boolean); stdcall;
begin
  if Parent > 0 then
  begin
    TThreadDosCommand(Parent).prvtWaitEvent(Output, Error, AbortProcess, IsComplete);
  end;
end;
 
{ TThreadCommand }
 
 
 
procedure TThreadDosCommand.setCommand(pCommand: string; pWaitEvent: TWaitEvent);
begin
  prvtCommand := pCommand;
  prvtWaitEvent := pWaitEvent;
end;
 
procedure TThreadDosCommand.Execute;
var
  ExitCode: Int64;
  OutputText: string;
  ErrorText: string;
begin
  inherited;
  CallCmd('', 'cmd.exe', '/C '+prvtCommand, ExitCode, OutputText, ErrorText, 0,  NativeUInt(Self), _TThreadDosCommandWaitEvent);
end;
 
end.

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
 
unit epcWindows;
 
interface
 
uses Windows, System.SysUtils;
 
{ * -----------------------------------------------------------------------------
  TCallCmdEvent pointeur de procédure ...
  @param Parent identifiant privé utilisé dans WaitEvent fourni par la fonction appelante de CallCmd
  @param Output contiennent les derniers éléments envoyés par le programme console sur le canal StdOut
  @param Error contiennent les derniers éléments envoyés par le programme console sur le canal StdError
  @param AbortProcess indique si la processus doit être arrêté
  @param IsComplete indique si le processus est terminé
  ------------------------------------------------------------------------------ }
type
  TCallCmdEvent = procedure(Parent: NativeUInt; const Output, Error: string;
    var AbortProcess: Boolean; IsComplete: Boolean); stdcall;
 
function CallCmd(const CmdDirectory, CmdName, CmdParam: string;
  out ExitCode: Int64; out OutputText: string; out ErrorText: string;
  Delay: Cardinal = INFINITE; Parent: NativeUInt = 0;
  WaitEvent: TCallCmdEvent = nil; PipeMaxSize: Cardinal = 0): Boolean;
 
implementation
 
uses Math;
 
{ * -----------------------------------------------------------------------------
  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 OutputText chaine contenant tout ce qui aurait du s'afficher (canal sortie)
  @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 Parent identifiant privé utilisé dans WaitEvent fourni par la fonction appelante de CallCmd
  @param WaitEvent procédure à lancer lorsque le Delay est écoulé, Output et Error contiennent les derniers éléments envoyés par le programme console sur les canaux depuis le dernier délai, AbortProcess indique si la processus doit être arrêté
  @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 CallCmd(const CmdDirectory, CmdName, CmdParam: string;
  out ExitCode: Int64; out OutputText: string; out ErrorText: string;
  Delay: Cardinal = INFINITE; Parent: NativeUInt = 0;
  WaitEvent: TCallCmdEvent = nil; PipeMaxSize: Cardinal = 0): Boolean;
var
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  CmdLine: string; // utile pour le débogage
  WorkDir: string;
  SecurityAttr: TSecurityAttributes;
  hReadPipeInput, hWritePipeInput: THandle;
  hReadPipeOutput, hWritePipeOutput: THandle;
  hReadPipeError, hWritePipeError: THandle;
  Terminated: Boolean;
  AbortProcess: Boolean;
  HandleFunctionProcess: Cardinal;
 
  function ReadPipe(Handle: Cardinal; out Buf: AnsiString): Boolean;
  const
    MAX_INT: Cardinal = MaxInt;
  var
    PipeSize: Cardinal;
    PipeToRead, PipeReaded: Cardinal;
    BufOem: 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(BufOem, PipeToRead);
      ZeroMemory(@BufOem[1], PipeToRead);
      ReadFile(Handle, BufOem[1], PipeToRead, PipeReaded, nil);
 
      SetLength(Buf, PipeReaded);
      OemToCharA(@BufOem[1], @Buf[1])
    end;
  end;
 
  procedure ReadPipes();
  var
    DeltaOutputText: AnsiString;
    DeltaErrorText: AnsiString;
  begin
    if ReadPipe(hReadPipeOutput, DeltaOutputText) then
      OutputText := OutputText + string(DeltaOutputText);
    if ReadPipe(hReadPipeError, DeltaErrorText) then
      ErrorText := ErrorText + string(DeltaErrorText);
    try
      if Assigned(WaitEvent) then
        WaitEvent(Parent, string(DeltaOutputText), string(DeltaErrorText), AbortProcess, false);
    except
      on E: Exception do
        OutputDebugString
          (PChar(Format('epcWindows.CallCmd.ReadPipes.WaitEvent - "%s" : "%s"',
          [E.ClassName, E.Message])));
    end;
  end;
 
begin
  OutputText := '';
  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 SameText(CmdName, 'cmd.exe') then
        begin
          CmdLine := Format('%s %s', [System.SysUtils.GetEnvironmentVariable('COMSPEC'), CmdParam]);
          WorkDir := ExtractFileDir(System.SysUtils.GetEnvironmentVariable('COMSPEC'));
        end
        else
        begin
          CmdLine := Format('"%s%s" %s', [IncludeTrailingPathDelimiter(CmdDirectory), CmdName, CmdParam]);
          WorkDir := CmdDirectory;
        end;
 
        Result := CreateProcess(nil, PChar(CmdLine), @SecurityAttr,
          @SecurityAttr, True, 0, nil, PChar(WorkDir), 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);
 
        if Assigned(WaitEvent) then
           WaitEvent(Parent, '', '', AbortProcess, true);
      end;
    end
    else
      raise Exception.Create('Impossible de créer les Pipes');
  except
    on E: Exception do
    begin
      OutputDebugString
        (PChar(Format('epcWindows.CallCmd Error %s, Message : %s',
        [E.ClassName, E.Message])));
      raise;
    end;
  end;
end;
 
end.

**ShaiLeTroll** · 11/10/2013, 19h01

Le processus est terminé lors que l'on sort de CallCmd

Tu penses asynchrone sur une fonction bêtement synchrone

tu aurais pu exploiter TThreadDosCommand.OnTerminated qui te l'aurais indiqué à la sortie du Execute()

Je supprimerais IsComplete dans epcWindows

Avec le code suivant lors du IsComplete à true, cela fourni le retour Output au complet !
C'est mieux que de le fournir vide !

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
procedure TThreadDosCommand.Execute;
var
  ExitCode: Int64;
  OutputText: string;
  ErrorText: string;
  Dummy: Boolean;
begin
  CallCmd('', 'cmd.exe', '/C '+prvtCommand, ExitCode, OutputText, ErrorText, 0,  NativeUInt(Self), _TThreadDosCommandWaitEvent);
 
  if Assigned(prvtWaitEvent)
    prvtWaitEvent(OutputText, ErrorText, Dummy, True);
end;

Code :

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

1
2
3
4
5
6
7
procedure _TThreadDosCommandWaitEvent(Parent: NativeUInt; const Output, Error: string; var AbortProcess: Boolean); stdcall;
begin
  if Parent > 0 then
  begin
    TThreadDosCommand(Parent).prvtWaitEvent(Output, Error, AbortProcess, false);
  end;
end;

**LaurentC33** · 14/10/2013, 09h57

Bonjour Shai et bon début de semaine.

Moins tordue ta solution

Tout marche nickel, sauf dans le code d'epcWindows :

ReadPipes() :

Code :

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

1
2
 
WaitEvent(Parent, string(DeltaOutputText), string(DeltaErrorText), AbortProcess);

Si on remplace par :

Code :

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

1
2
 
WaitEvent(Parent, string(DeltaErrorText), string(DeltaOutputText), AbortProcess);

Ca marche.

Les valeurs de ErrorText et OutputText sont inversés

**ShaiLeTroll** · 14/10/2013, 18h38

Inversée ?
Cela m'étonne !
Pour l'avoir testé avec IpConfig, j'ai juste affiché Output sans rien inversé !

un petit

?

**LaurentC33** · 15/10/2013, 09h04

Laisse tomber, j'ai du faire le boulot je vérifierais (c'est sur l'output du WaitEvent et non celui retourné par la méthode)

En tout cas un grand merci !
(je pensais avoir mis résolu depuis la semaine dernière

)

**hfr11** · 30/03/2022, 20h11

Je suis tombé sur ce programme par hasard et j'ai trouvé génial de pouvoir exécuter une commande DOS en retrouvant son retour dans un mémo...
Sur Delphi CODEGEAR RAD STUDIO 6 jusqu'à aujourd'hui et pas de problème... Mais
Ras le bol des bugs, je suis revenu à Delphi 7 mais là,
Déclaration : "Type TArg<T> = reference To Procedure(Const Arg: T);" --> [Erreur] UDeclarations.pas(79): '=' attendu(e) mais '<' trouvé(e)
Mon niveau de programmeur est dépassé !

Problème rencontré avec l'autre version de Delphi, avec un TreeView :

NodeTemp:=GetFirstChild;
While NodeTemp<>Nil Do Begin
If NodeTemp.Text=LePC Then Break
Else NodeTemp:=GetNextSibling;
Application.ProcessMessages;
End;

Le programme boucle à l'infini alors qu'il n'y a que le noeud Root et plus tard dans le programme 3 noeuds (Root, User et LePC) ! (même problème avec GetNext). J'y perd mon latin !

Merci et bonne fin de jurnée aux bons programmeur pour une aide éventuelle...

Mieux vaut demander à un qui sait plutôt qu'à dix qui cherchent...

**popo** · 31/03/2022, 08h51

Le <T> est simplement la manière d'exprimer la généricité.
Cela n'existe pas dans Delphi 7, c'est apparu avec Delphi 2009 (si ma mémoire ne me trompe pas).

Je note que tu es revenu à Delphi 7.
Pour moi, tu te tires toi même une balle dans le pied en revenant à une techno vieille de 20 ans et qui fonctionnera uniquement sur les systèmes 32 bits.

PS :
Au passage, le vote négatif, c'est moi.
Pour avoir déterré un sujet de 2013 et y avoir rajouté un problème qui n'a rien à voir avec le sujet original.

**SergioMaster** · 31/03/2022, 08h53

Envoyé par hfr11

Sur Delphi CODEGEAR RAD STUDIO 6

Il faut certainement lire XE 6 mais du coup ce n'est pas CodeGear

alors D2006 ?

**ShaiLeTroll** · 31/03/2022, 09h22

Ce qui est dommage c'est d'avoir repris le premier code du sujet qui n'est pas codé correctement et l'auteur lui même dit qu'il y a des problèmes, en lisant la suite, vous auriez aussi constaté qu'il avait comme vous de grosses difficultés, un peu dépassé comme vous.

Alors qu'un peu plus loin, il un code D7 parfaitement fonctionnel, je vous conseille d'avancer encore car l'échange justement affine le besoin et les différences entre D7 et XE2 et l'anticipation d'un typage fort pour le 64Bits, d'ailleurs en cours de route une version améliorée apparait.

Commande DOS affichée dans memo, le tout dans un thread

Delphi

Discussions similaires

Partager

Partager