Faire un Ping en Delphi [Résolu]

Signaler
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
-
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
-
Bonjour j'ai poster ce post dans le forum High-Tech (http://www.commentcamarche.net/forum/affich-30549445-faire-un-ping-en-delphi#p30550182) et je souhaiterai savoir comment faire. Merci

12 réponses

Messages postés
3816
Date d'inscription
vendredi 23 juillet 2004
Statut
Modérateur
Dernière intervention
5 septembre 2020
34
re,

ShellExecute étant fortement déconseillé par Delphi qui préconise l'utilisation de CreateProcess à la place ...
voici un petit exemple qui va te plaire j'en suis certain ^^

sur une TForm tu places 1 TMemo et 1 TButton et tu complètes comme suit:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Déclarations privées }
  public
    { Déclarations publiques }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}
{ code original de Zarko Gajic:
  http://delphi.about.com/cs/adptips2001/a/bltip0201_2.htm
  Modifié par Cirec}
procedure RunDosInMemo(const DosApp: string; const AMemo: TMemo);
const
  ReadBuffer = 2400;
var
  Security: TSecurityAttributes;
  ReadPipe, WritePipe: THandle;
  start: TStartUpInfo;
  ProcessInfo: TProcessInformation;
  Buffer: Pchar;
  BytesRead: DWord;
begin
  with Security do
  begin
    nlength := SizeOf(TSecurityAttributes);
    binherithandle := true;
    lpsecuritydescriptor := nil;
  end;
  if Createpipe(ReadPipe, WritePipe, @Security, 0) then
  try
    FillChar(Start, Sizeof(Start), #0);
    start.cb := SizeOf(start);
    start.hStdOutput := WritePipe;
    start.hStdInput := ReadPipe;
    start.dwFlags := STARTF_USESTDHANDLES +
      STARTF_USESHOWWINDOW;
    start.wShowWindow := SW_HIDE;

    if CreateProcess(nil, PChar(DosApp), @Security, @Security, true,
         NORMAL_PRIORITY_CLASS, nil, nil, start, ProcessInfo) then
    try
      repeat
        Application.ProcessMessages;
      until (WaitForSingleObject(ProcessInfo.hProcess, 100) <> WAIT_TIMEOUT);
      Buffer := AllocMem(ReadBuffer + 1);
      try
        repeat
          BytesRead := 0;
          ReadFile(ReadPipe, Buffer[0], ReadBuffer, BytesRead, nil);
          Buffer[BytesRead] := #0;
          OemToAnsi(Buffer, Buffer);
          AMemo.Text := AMemo.text + string(Buffer);
        until (BytesRead < ReadBuffer);
      finally
        FreeMem(Buffer);
      end;
    finally
      CloseHandle(ProcessInfo.hProcess);
      CloseHandle(ProcessInfo.hThread);
    end;
  finally
    CloseHandle(ReadPipe);
    CloseHandle(WritePipe);
  end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
  Caption := 'Requette en cour ...';
  Memo1.Clear;
  RunDosInMemo('cmd.exe /k Ping Google.fr', Memo1);
  Caption := 'Requette terminée';
end;

end.



Les avantages sont:
le résultat est directement affiché dans un TMemo ... pas de traces sur le disque ... pas besoin de charger le fichier pour le lire.
La procédure attend la fin de l'exécution de la commande avant d'aller plus loin (on s'en rend compte avec l'affichage du caption avant et après l'exécution)
Bien sur l'application n'est pas figée durant l'exécution.
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
Effectivement je l'aime ton code (IL EST LONG 8-0)... Je vais le tester.
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
Il marche! (J'ai rien compris à ton code, je vois juste qu'il agit un peu comme CMD). Je vais quand même tester celui de cs_yanb.
Le code de la fiche est :
object Form1: TForm1
Left = 192
Top = 122
Width = 557
Height = 117
Caption = 'Pinger'
Color = clBtnFace
Constraints.MaxHeight = 117
Constraints.MinHeight = 117
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Button1: TButton
Left = 0
Top = 56
Width = 541
Height = 25
Anchors = [akLeft, akTop, akRight]
Caption = 'Ping'
TabOrder = 0
OnClick = Button1Click
end
object Panel1: TPanel
Left = 0
Top = 0
Width = 541
Height = 23
Align = alTop
AutoSize = True
BevelOuter = bvNone
TabOrder = 1
object Label1: TLabel
Left = 0
Top = 0
Width = 38
Height = 23
Align = alLeft
Caption = 'Adresse'
Layout = tlCenter
end
object EditPing: TEdit
Left = 41
Top = 1
Width = 500
Height = 21
Anchors = [akLeft, akTop, akRight]
TabOrder = 0
end
end
object RadioGroupFormatIP: TRadioGroup
Left = 0
Top = 23
Width = 541
Height = 34
Align = alTop
Caption = 'Afficher l'#39'adresse'
Columns = 3
ItemIndex = 0
Items.Strings = (
'IPv4 ou IPv6'
'IPv4'
'IPv6')
TabOrder = 2
end
end
Celui de l'unité :
unit Main;

interface

uses
Windows, Classes, SysUtils, Forms, ExtCtrls, StdCtrls, Controls;

type
TForm1 = class(TForm)
Button1: TButton;
Panel1: TPanel;
EditPing: TEdit;
Label1: TLabel;
RadioGroupFormatIP: TRadioGroup;
procedure Button1Click(Sender: TObject);
private
{ Déclarations privées }
public
{ Déclarations publiques }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

{ code original de Zarko Gajic:
http://delphi.about.com/cs/adptips2001/a/bltip0201_2.htm
Modifié par Cirec}
Function RunDosInMemo(const DosApp: string):TStringList;
const
ReadBuffer = 2400;
var
Security: TSecurityAttributes;
ReadPipe, WritePipe: THandle;
start: TStartUpInfo;
ProcessInfo: TProcessInformation;
Buffer: Pchar;
BytesRead: DWord;
begin
Result := TStringList.Create;
with Security do
begin
nlength := SizeOf(TSecurityAttributes);
binherithandle := true;
lpsecuritydescriptor := nil;
end;
if Createpipe(ReadPipe, WritePipe, @Security, 0) then
try
FillChar(Start, Sizeof(Start), #0);
start.cb := SizeOf(start);
start.hStdOutput := WritePipe;
start.hStdInput := ReadPipe;
start.dwFlags := STARTF_USESTDHANDLES +
STARTF_USESHOWWINDOW;
start.wShowWindow := SW_HIDE;

if CreateProcess(nil, PChar(DosApp), @Security, @Security, true,
NORMAL_PRIORITY_CLASS, nil, nil, start, ProcessInfo) then
try
repeat
Application.ProcessMessages;
until (WaitForSingleObject(ProcessInfo.hProcess, 100) <> WAIT_TIMEOUT);
Buffer := AllocMem(ReadBuffer + 1);
try
repeat
BytesRead := 0;
ReadFile(ReadPipe, Buffer[0], ReadBuffer, BytesRead, nil);
Buffer[BytesRead] := #0;
OemToAnsi(Buffer, Buffer);
Result.Text := Result.text + string(Buffer);
until (BytesRead < ReadBuffer);
finally
FreeMem(Buffer);
end;
finally
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
end;
finally
CloseHandle(ReadPipe);
CloseHandle(WritePipe);
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
Var
Ping:TStringList;
begin
If RadioGroupFormatIP.ItemIndex <> 0 Then
MessageBox(Handle,'Attention si l''hote n''est pas trouver réésayer en sélectionnant "IPv4 ou IPv6"','IPv4 ou IPv6 forçer',MB_ICONWARNING);
Case RadioGroupFormatIP.ItemIndex of
0:Ping := RunDosInMemo('Ping -n 1 -w 1000 ' + EditPing.Text);//IPv4 ou IPv6
1:Ping := RunDosInMemo('Ping -n 1 -w 1000 -4 ' + EditPing.Text);//IPv4
2:Ping := RunDosInMemo('Ping -n 1 -w 1000 -6 ' + EditPing.Text);//IPv6
end;
If Pos('[',Ping.Text) <> 0 Then
MessageBox(Handle,PChar(EditPing.Text + ' à été trouver à l''IP '+Copy(Ping.Text,Pos('[',Ping.Text)+1,Pos(']',Ping.Text)-1-Pos('[',Ping.Text))),PChar(EditPing.Text + ' trouver'),MB_ICONINFORMATION)
Else MessageBox(Handle,PChar(EditPing.Text + ' n''a pas été trouver'),PChar(EditPing.Text + ' non trouver'),MB_ICONINFORMATION);
end;

end.

Merci
Messages postés
3816
Date d'inscription
vendredi 23 juillet 2004
Statut
Modérateur
Dernière intervention
5 septembre 2020
34
Salut,

oui c'est le même principe à ceci près ... dans ton code tu oublies de fermer les Handles créés avec CreateProcess.

tu peux vérifier sur la MSDN
Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed.

du fait de l'utilisation de INFINITE dans:
WaitForSingleObject(ProcessInformation.hProcess, INFINITE);
l'application reste figée le temps de l'exécution (ok là c'est assez rapide)

et l'encadrement du code dans des blocs try finally ne me semble pas être du luxe ^^
ça nous garantie la libération des objets en toutes circonstances.

sinon c'est pareil ^^
et oui j'essaye d'être plus présent sur le site mais c'est pas toujours facile.
Messages postés
257
Date d'inscription
lundi 27 octobre 2003
Statut
Membre
Dernière intervention
20 août 2020
8
Salut,
tout juste, effectivement les CloseHandle sur le CreateProcess j'avais pas vu, et c'est vrai l'appli reste bloquée si on fait une demande assez longue et c'est un peu gênant..., pour le try finally je l'ai remarqué après avoir posté ;)
C'est noté et corrigé, Merci Cirec
@+
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
Personne?
Messages postés
257
Date d'inscription
lundi 27 octobre 2003
Statut
Membre
Dernière intervention
20 août 2020
8
Salut,
sans Indy regarde du côté de ICMP
@+
Messages postés
251
Date d'inscription
dimanche 7 décembre 2003
Statut
Membre
Dernière intervention
11 novembre 2016

Bonjour

vous pouvez regarder non source qui utilise ICMP
http://codes-sources.commentcamarche.net/source/43756-monitoring-reseau-par-ping
tout est dans icmp.pas

--
Messages postés
3816
Date d'inscription
vendredi 23 juillet 2004
Statut
Modérateur
Dernière intervention
5 septembre 2020
34
Salut,

1°) les composants Indy9 ou Indy10 sont disponibles gratuitement pour toutes les versions de Delphi et même pour Delphi5

2°) utiliser la solution de fbalien

3°) par une commande Dos (le plus simple à mettre en oeuvre)
Ping Google.fr > Result.txt

le résultat du Ping se trouve dans le fichier Result.txt !!!
Envoi d'une requête 'ping' sur google.fr [173.194.40.184] avec 32 octets de données :

Réponse de 173.194.40.184 : octets=32 temps=52 ms TTL=45
Réponse de 173.194.40.184 : octets=32 temps=51 ms TTL=45
Réponse de 173.194.40.184 : octets=32 temps=51 ms TTL=45
Réponse de 173.194.40.184 : octets=32 temps=51 ms TTL=45

Statistiques Ping pour 173.194.40.184:
Paquets : envoyés = 4, reçus = 4, perdus = 0 (perte 0%),

Durée approximative des boucles en millisecondes :
Minimum = 51ms, Maximum = 52ms, Moyenne = 51ms


Maintenant tu as le choix
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
Efectivement j'ai installer hier Indy 9 (je ne suis pas allé sur Codes sources hier) mais perso je trouve que indy est complexe je n'ai pas trouver comment recevoir des messages mais indy permet la mise en oeuvre de SSL et offre plus de possibilité c'est vrai.

J'ai regarder la solution de fbalien mais Delphi trouve des erreurs (dcu variants absent et le mot "ifthen")

Je vais essayer ta solution "ping dos" (je vais rechercher comment en fait déjà shellexecute) puis je vais poster si ça marche. Merci.

Chercher et essayer : vous trouverez la solution!
Fouiner et regarder partout : vous trouverez la connaissance!!
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
Jai 2 bugs :

1- Le ping ne veut pas m'écrire le fichier
2- Le TStrings ne veut pas m'ouvrir le fichier d'un ping fontionnel

Voici le code :
unit Unit1;

interface

uses
  Windows, Forms, Dialogs, ShellApi, Classes, Controls, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    procedure Button1Click(Sender: TObject);
  private
    { Déclarations privées }
  public
    { Déclarations publiques }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
Var
Fileping:TStrings;
begin
Fileping := TStrings.Create;//Initialisation de Fileping
ShellExecute(Handle,'open',Pchar('Ping '+Edit1.Text+' > Result.txt'),nil,nil,SW_SHOW);//Ping
Fileping.LoadFromFile('Result.txt');//Chargement du ping
If Pos(Fileping.Text,'[') <> 0 Then//Ping OK?
ShowMessage(Edit1.Text + ' trouver')//Ping ok
Else ShowMessage(Edit1.Text + ' non trouver')//Ping pas ok
end;

end.


SVP trouver l'erreur merci.

Note : j'ai remarquer que le caractère "[" n'est présent que si l'hote existe, je l'utilise pour savoir si l'hote existe

Chercher et essayer : vous trouverez la solution!
Fouiner et regarder partout : vous trouverez la connaissance!!
Messages postés
251
Date d'inscription
dimanche 7 décembre 2003
Statut
Membre
Dernière intervention
11 novembre 2016

Bonjour

ifthen normalement est présent dans l'unité math peut être pas en delphi5

si non pour la version dos ping
1/ ne pas oublier de libérer les objet instanciés (Fileping.free en fin de procedure)
2/ pour avoir le resultat du ping via shellexecute il faut passer par un fichier batch

  Fileping := TStringList.Create;//Initialisation de Fileping
fileping.Add('Ping ' + edit1.Text + ' > c:\result.txt');
fileping.SaveToFile('cmdping.cmd');
err := ShellExecute(Handle,'open',Pchar('cmdping.cmd' ),nil ,nil,SW_SHOW);//Ping
ShowMessage(SysErrorMessage(err) );
Fileping.LoadFromFile('c:\Result.txt');//Chargement du ping
If Pos(Fileping.Text,'[') <> 0 Then//Ping OK?
ShowMessage(Edit1.Text + ' trouver')//Ping ok
Else ShowMessage(Edit1.Text + ' non trouver');//Ping pas ok
Fileping.free

/!\ il faudra adapter le parse du fichier resultat.txt
--
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
Je vais tester...
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
ça marche ! J'ai juste un peu modifier le code:
procedure TForm1.Button1Click(Sender: TObject);
Var
Fileping:TStringList;
begin
Fileping := TStringList.Create;//Initialisation de Fileping
fileping.Add('Ping /n 1 /W 1000 ' + edit1.Text + ' > result.txt');
fileping.SaveToFile('cmdping.cmd');
ShellExecute(Handle,'open',Pchar('cmdping.cmd' ),nil ,nil,SW_SHOW);//Ping
Sleep(1000);
Fileping.LoadFromFile('Result.txt');//Chargement du ping
If Pos('[',Fileping.Text) <> 0 Then//Ping OK?
ShowMessage(Edit1.Text + ' trouver')//Ping ok
Else ShowMessage(Edit1.Text + ' non trouver');//Ping pas ok
Fileping.free;
end;

ps : SVP à l'avenir précise le type des variables merci
Messages postés
257
Date d'inscription
lundi 27 octobre 2003
Statut
Membre
Dernière intervention
20 août 2020
8
Salut,
je ne pense pas qu'il soit nécessaire de passer par un fichier batch,il faudrait essayer ceci
ShellExecute(0,'Open',PChar('CMD.exe'),PChar('/C Ping '+Edit1.Text+' > C:\Result.txt'), nil, SW_SHOW);
TStrings NON, mais TStringList...
Ensuite il me semble que la fonction Pos fonctionne plus comme ceci
Pos('[', Fileping.Text)
par contre il va falloir attendre la fin du ping...peut être ne faire qu'une demande déjà
ShellExecute(0,'Open',PChar('CMD.exe'),PChar('/C Ping '+Edit1.Text+' /n 1 > C:\Result.txt'), nil, SW_HIDE);
Et ensuite...un peu de recherche pour le traitement du fichier ;-)
@+
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
Pour le ping j'ai mit un ping avec un timeout de 1s. Et merci pour Pos
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
Ton code bug (PING ne veut pas me crée le fichier).
Messages postés
257
Date d'inscription
lundi 27 octobre 2003
Statut
Membre
Dernière intervention
20 août 2020
8
Salut Cirec,
Raaa trop rapide comme d'hab :p ^^,
Bah au moins c'est de bonne augure de revoir des "anciens" plus souvent ;-)
bon ben je met quand même le morceau de code que j'avais trouvé ( il me semble de Paul Toth à l'époque ) et que j'avais adapté il y a quelques années...fallait juste que je le retrouve...
procedure RunCmd(ComCmd: string; S: TStrings);
var
PipeIn : THandle;
PiPeOut : THandle;
SecurityAttributes : TSecurityAttributes;
StartupInfo : TStartupInfo;
ProcessInformation : TProcessInformation;
Buffer : array[0..4096] of AnsiChar;
LengthRead : DWORD;
begin
With SecurityAttributes do
begin
nlength := SizeOf(TSecurityAttributes) ;
binherithandle := true;
lpsecuritydescriptor := nil;
end;
CreatePipe(PipeIn, PiPeOut, @SecurityAttributes, 0);
FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
StartupInfo.cb := SizeOf(TStartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
StartupInfo.wShowWindow := SW_HIDE;
StartupInfo.hStdInput := PipeIn;
StartupInfo.hStdOutput:= PiPeOut;
StartupInfo.hStdError := PiPeOut;
CreateProcess(nil, PChar(ComCmd), nil, nil, True, 0, nil, nil, StartupInfo, ProcessInformation);
WaitForSingleObject(ProcessInformation.hProcess, INFINITE);
CloseHandle(PiPeOut);
while ReadFile(PipeIn, Buffer, 4096, LengthRead, nil) do
OemToAnsi(Buffer, Buffer);
S.Add(Buffer);
CloseHandle(PipeIn);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
RunCmd('ping '+Edit1.Text+' /n 1', Memo1.Lines);
end;
@+
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
Ton code bug (il ne trouve pas ComCMD)
Messages postés
29524
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
12 septembre 2020
336
C'est une PROCEDURE...
ComCMD est passé en paramètres.....
Comment l'as tu lancé ??
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
Mince j'avais mal orthographier ComCMD. Ton code marche mais tronque des valeur (je récupère la vitesse et le code fbalien tronque moins de texte). Sinon merci quand même ;-)
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
Bonjour à tous

Je vois que vous avez poster BEAUCOUP DE POST!! 8-0

Maintenant je vais tout tester et merci de votre participation.
;-)
Messages postés
653
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
5
Merci à vous tous maintenant je sais faire un Ping en Delphi.