Sujet Précédent Sujet Suivant

Faire un Ping en Delphi

Résolu
MiniApp Messages postés 654 Date d'inscription lundi 21 juillet 2014 Statut Membre Dernière intervention 22 février 2019 - 23 juil. 2014 à 19:20
MiniApp Messages postés 654 Date d'inscription lundi 21 juillet 2014 Statut Membre Dernière intervention 22 février 2019 - 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

12 réponses

Réponse 1 / 12
Cirec Messages postés 3833 Date d'inscription vendredi 23 juillet 2004 Statut Modérateur Dernière intervention 18 septembre 2022 50
28 juil. 2014 à 16:26
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.
1
MiniApp Messages postés 654 Date d'inscription lundi 21 juillet 2014 Statut Membre Dernière intervention 22 février 2019 5
29 juil. 2014 à 11:52
Effectivement je l'aime ton code (IL EST LONG 8-0)... Je vais le tester.
0
MiniApp Messages postés 654 Date d'inscription lundi 21 juillet 2014 Statut Membre Dernière intervention 22 février 2019 5
Modifié par MiniApp le 29/07/2014 à 14:37
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
0

Discussions similaires

Ping en VbScript
fdthierry -
jmvd2 -

11 réponses
DCPcrypt
totti16 -
LeiiNats.DEV -

1 réponse
Filtrage (recherche) Delphi
Aminos17 -
Aminos17 -

10 réponses
interval entre deux temps
AMINE-SUBZERO -
Francky23012301 -

5 réponses
Expoter une table MySql et stocker dans un fichier.sql ou .ini
Manoupier -
Utilisateur anonyme -

3 réponses
DBMemo
ajali -
cs_cantador -

2 réponses
Rejoignez-nous