1. Accueil
  2. Forum Codes-Sources
  3. Delphi / Pascal

Faire un Ping en Delphi [Résolu]

Signaler
Messages postés
655
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
 -
Messages postés
655
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
Afficher la suite
A voir également:

12 réponses

Réponse 1 / 12
Messages postés
3808
Date d'inscription
vendredi 23 juillet 2004
Statut
Modérateur
Dernière intervention
14 mai 2020
 28
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.
Signaler
Messages postés
655
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.
Signaler
Messages postés
655
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
Réponse 2 / 12
Messages postés
655
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
 5
Personne?
Réponse 3 / 12
Messages postés
250
Date d'inscription
lundi 27 octobre 2003
Statut
Membre
Dernière intervention
2 décembre 2019
 5
Salut,
sans Indy regarde du côté de ICMP
@+
Réponse 4 / 12
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

--
Réponse 5 / 12
Messages postés
3808
Date d'inscription
vendredi 23 juillet 2004
Statut
Modérateur
Dernière intervention
14 mai 2020
 28
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
Réponse 6 / 12
Messages postés
655
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!!
Réponse 7 / 12
Messages postés
655
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!!
Réponse 8 / 12
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
--
Signaler
Messages postés
655
Date d'inscription
lundi 21 juillet 2014
Statut
Membre
Dernière intervention
22 février 2019
 5
Je vais tester...
Signaler
Messages postés
655
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
Réponse 9 / 12
Messages postés
250
Date d'inscription
lundi 27 octobre 2003
Statut
Membre
Dernière intervention
2 décembre 2019
 5
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 ;-)
@+
Signaler
Messages postés
655
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
Signaler
Messages postés
655
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).
Réponse 10 / 12
Messages postés
250
Date d'inscription
lundi 27 octobre 2003
Statut
Membre
Dernière intervention
2 décembre 2019
 5
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;
@+
Signaler
Messages postés
655
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)
Signaler
Messages postés
28777
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
15 mai 2020
 327
C'est une PROCEDURE...
ComCMD est passé en paramètres.....
Comment l'as tu lancé ??
Signaler
Messages postés
655
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 ;-)
Réponse 11 / 12
Messages postés
3808
Date d'inscription
vendredi 23 juillet 2004
Statut
Modérateur
Dernière intervention
14 mai 2020
 28
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.
Signaler
Messages postés
250
Date d'inscription
lundi 27 octobre 2003
Statut
Membre
Dernière intervention
2 décembre 2019
 5
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
@+
Réponse 12 / 12
Messages postés
655
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.
;-)
Signaler
Messages postés
655
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.
Répondre Posez votre question