Faire un Ping en Delphi [Résolu]

Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
- - Dernière réponse : MiniApp
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
- 29 juil. 2014 à 18:34
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 

Votre réponse

12 réponses

Meilleure réponse
Messages postés
4229
Date d'inscription
vendredi 23 juillet 2004
Statut
Modérateur
Dernière intervention
3 août 2018
1
Merci
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.

Merci Cirec 1

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources a aidé 97 internautes ce mois-ci

MiniApp
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
-
Effectivement je l'aime ton code (IL EST LONG 8-0)... Je vais le tester.
MiniApp
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
-
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
Commenter la réponse de Cirec
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
0
Merci
Personne?
Commenter la réponse de MiniApp
Messages postés
260
Date d'inscription
lundi 27 octobre 2003
Dernière intervention
4 mars 2016
0
Merci
Salut,
sans Indy regarde du côté de ICMP
@+
Commenter la réponse de cs_yanb
Messages postés
265
Date d'inscription
dimanche 7 décembre 2003
Dernière intervention
11 novembre 2016
0
Merci
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

--
Commenter la réponse de fbalien
Messages postés
4229
Date d'inscription
vendredi 23 juillet 2004
Statut
Modérateur
Dernière intervention
3 août 2018
0
Merci
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
Commenter la réponse de Cirec
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
0
Merci
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!!
Commenter la réponse de MiniApp
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
0
Merci
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!!
Commenter la réponse de MiniApp
Messages postés
265
Date d'inscription
dimanche 7 décembre 2003
Dernière intervention
11 novembre 2016
0
Merci
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
--
MiniApp
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
-
Je vais tester...
MiniApp
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
-
ç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
Commenter la réponse de fbalien
Messages postés
260
Date d'inscription
lundi 27 octobre 2003
Dernière intervention
4 mars 2016
0
Merci
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 ;-)
@+
MiniApp
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
-
Pour le ping j'ai mit un ping avec un timeout de 1s. Et merci pour Pos
MiniApp
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
-
Ton code bug (PING ne veut pas me crée le fichier).
Commenter la réponse de cs_yanb
Messages postés
260
Date d'inscription
lundi 27 octobre 2003
Dernière intervention
4 mars 2016
0
Merci
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;
@+
MiniApp
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
-
Ton code bug (il ne trouve pas ComCMD)
jordane45
Messages postés
23569
Date d'inscription
mercredi 22 octobre 2003
Statut
Modérateur
Dernière intervention
10 décembre 2018
-
C'est une PROCEDURE...
ComCMD est passé en paramètres.....
Comment l'as tu lancé ??
MiniApp
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
-
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 ;-)
Commenter la réponse de cs_yanb
Messages postés
4229
Date d'inscription
vendredi 23 juillet 2004
Statut
Modérateur
Dernière intervention
3 août 2018
0
Merci
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.
cs_yanb
Messages postés
260
Date d'inscription
lundi 27 octobre 2003
Dernière intervention
4 mars 2016
-
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
@+
Commenter la réponse de Cirec
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
0
Merci
Bonjour à tous

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

Maintenant je vais tout tester et merci de votre participation.
;-)
MiniApp
Messages postés
654
Date d'inscription
lundi 21 juillet 2014
Dernière intervention
5 décembre 2018
-
Merci à vous tous maintenant je sais faire un Ping en Delphi.
Commenter la réponse de MiniApp

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.