Как сделать Ping?

Протокол Ping предназначен для тестирования компьютерных соединений в Интернете путём посылки через протокол Internet Protocol (IP) по обределённому адресу сообщения и ожидания от него ответа.

ICMP - Internet Control Message Protocol. ICMP служит для передачи сообщений об ошибках а так же управляющих сообщений . ICMP-тест может показать насколько быстро проходит информация между двумя узлами в Интернете.

1. Запускаем Delphi;

2. В Новом проекте добавляем в форму Tbutton, Tedit и Tmemo;

3. Вставляем "winsock";

4. объявляем структурку для IP-заголовка:

   type
     IPINFO = record
       Ttl: char;
       Tos: char;
       IPFlags: char;
       OptSize: char;
       Options: ^char;
     end;
   

5. объявляем структурку для хранения ICMP пакета:

   type
     ICMPECHO = record
       Source: longint;
       Status: longint;
       RTTime: longint;
       DataSize: Shortint;
       Reserved: Shortint;
       pData: ^variant;
       i_ipinfo: IPINFO;
     end;
   

6. Объявляем функции и процедуры, которые мы будем вызывать из ICMP.DLL

   TIcmpCreateFile = function():integer; {$IFDEF WIN32} stdcall; {$ENDIF} 
   TIcmpCloseHandle = procedure(var handle:integer);{$IFDEF WIN32} stdcall; {$ENDIF} 
   TIcmpSendEcho = function(var handle:integer; endereco:DWORD; buffer:variant; tam:WORD; IP:IPINFO; ICMP:ICMPECHO; tamicmp:DWORD; tempo:DWORD):DWORD;{$IFDEF WIN32} stdcall; {$ENDIF} 
   

7. В Tbutton в событие Onclick вставляем следующий код:

   procedure TForm1.Button1Click(Sender: TObject);
   var
     wsadt: wsadata;
     icmp: icmpecho;
     HNDicmp: integer;
     hndFile: integer;
     Host: PHostEnt;
     Destino: in_addr;
     Endereco: ^DWORD;
     IP: ipinfo;
     Retorno: integer;
     dwRetorno: DWORD;
     x: integer;
   
     IcmpCreateFile: TIcmpCreateFile;
     IcmpCloseHandle: TIcmpCloseHandle;
     IcmpSendEcho: TIcmpSendEcho;
   
   begin
     if (edit1.Text = '') then
       begin
         Application.MessageBox('Enter a HostName ro a IP Adress',
           'Error', MB_OK);
         exit;
       end;
     HNDicmp := LoadLibrary('ICMP.DLL');
     if (HNDicmp <> 0) then
       begin
         @IcmpCreateFile := GetProcAddress(HNDicmp, 'IcmpCreateFile');
         @IcmpCloseHandle := GetProcAddress(HNDicmp, 'IcmpCloseHandle');
         @IcmpSendEcho := GetProcAddress(HNDicmp, 'IcmpSendEcho');
         if (@IcmpCreateFile = nil) or (@IcmpCloseHandle = nil) or (@IcmpSendEcho = nil) then
           begin
             Application.MessageBox('Error getting ICMP Adress', 'Error', MB_OK);
             FreeLibrary(HNDicmp);
           end;
       end;
     Retorno := WSAStartup($0101, wsadt);
   
     if (Retorno <> 0) then
       begin
         Application.MessageBox('Canґt Load WinSockets', 'WSAStartup', MB_OK);
         WSACleanup();
         FreeLibrary(HNDicmp);
       end;
   
     Destino.S_addr := inet_addr(Pchar(Edit1.text));
     if (Destino.S_addr = 0) then
       begin
         Host := GetHostbyName(PChar(Edit1.text));
       end
     else
       begin
         Host := GetHostbyAddr(@Destino, sizeof(in_addr), AF_INET);
       end;
   
     if (host = nil) then
       begin
         Application.MessageBox('Host not found', 'Error', MB_OK);
         WSACleanup();
         FreeLibrary(HNDicmp);
         exit;
       end;
     memo1.Lines.Add('Pinging ' + Edit1.text);
   
     Endereco := @Host.h_addr_list;
   
     HNDFile := IcmpCreateFile();
     for x := 0 to 4 do
       begin
         Ip.Ttl := char(255);
         Ip.Tos := char(0);
         Ip.IPFlags := char(0);
         Ip.OptSize := char(0);
         Ip.Options := nil;
   
         dwRetorno := IcmpSendEcho(
           HNDFile,
           Endereco^,
           null,
           0,
           Ip,
           Icmp,
           sizeof(Icmp),
           DWORD(5000));
         Destino.S_addr := icmp.source;
         Memo1.Lines.Add('Ping ' + Edit1.text);
       end;
   
     IcmpCLoseHandle(HNDFile);
     FreeLibrary(HNDicmp);
     WSACleanup();
   end;
   

У данного примера есть один недостаток - программа не воспримет доменное имя, только IP-адресс. Для пользователей NT не используйте функцию IcmpCloseHandle.

Это всё.....

Ну и в конце полный исходный код примера:

unit Unit1;

interface

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

type
  IPINFO = record
    Ttl: char;
    Tos: char;
    IPFlags: char;
    OptSize: char;
    Options: ^char;
  end;

type
  ICMPECHO = record
    Source: longint;
    Status: longint;
    RTTime: longint;
    DataSize: Shortint;
    Reserved: Shortint;
    pData: ^variant;
    i_ipinfo: IPINFO;
  end;

  TIcmpCreateFile = function(): integer; {$IFDEF WIN32}stdcall; {$ENDIF}
  TIcmpCloseHandle = procedure(var handle: integer); {$IFDEF WIN32}stdcall; {$ENDIF}
  TIcmpSendEcho = function(var handle: integer; endereco: DWORD; buffer: variant; tam: WORD; IP: IPINFO; ICMP: ICMPECHO; tamicmp: DWORD; tempo: DWORD): DWORD; {$IFDEF WIN32}stdcall; {$ENDIF}

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
{ Private declarations }
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  wsadt: wsadata;
  icmp: icmpecho;
  HNDicmp: integer;
  hndFile: integer;
  Host: PHostEnt;
  Destino: in_addr;
  Endereco: ^DWORD;
  IP: ipinfo;
  Retorno: integer;
  dwRetorno: DWORD;
  x: integer;

  IcmpCreateFile: TIcmpCreateFile;
  IcmpCloseHandle: TIcmpCloseHandle;
  IcmpSendEcho: TIcmpSendEcho;

begin
  if (edit1.Text = '') then
    begin
      Application.MessageBox('Digite um HostName ou um End. IP',
        'Error', MB_OK);
      exit;
    end;
  HNDicmp := LoadLibrary('ICMP.DLL');
  if (HNDicmp <> 0) then
    begin
      @IcmpCreateFile := GetProcAddress(HNDicmp, 'IcmpCreateFile');
      @IcmpCloseHandle := GetProcAddress(HNDicmp, 'IcmpCloseHandle');
      @IcmpSendEcho := GetProcAddress(HNDicmp, 'IcmpSendEcho');
      if (@IcmpCreateFile = nil) or (@IcmpCloseHandle = nil) or (@IcmpSendEcho = nil) then
        begin
          Application.MessageBox('Erro pegando endereзos ICMP', 'Error', MB_OK);
          FreeLibrary(HNDicmp);
        end;
    end;
  Retorno := WSAStartup($0101, wsadt);

  if (Retorno <> 0) then
    begin
      Application.MessageBox('Nгo foi possнvel carregar WinSockets', 'WSAStartup', MB_OK);
      WSACleanup();
      FreeLibrary(HNDicmp);
    end;

  Destino.S_addr := inet_addr(Pchar(Edit1.text));
  if (Destino.S_addr = 0) then
    begin
      Host := GetHostbyName(PChar(Edit1.text));
    end
  else
    begin
      Host := GetHostbyAddr(@Destino, sizeof(in_addr), AF_INET);
    end;

  if (host = nil) then
    begin
      Application.MessageBox('Host nгo encontrado', 'Error', MB_OK);
      WSACleanup();
      FreeLibrary(HNDicmp);
      exit;
    end;
  memo1.Lines.Add('Pinging ' + Edit1.text);

  Endereco := @Host.h_addr_list;

  HNDFile := IcmpCreateFile();
  for x := 0 to 4 do
    begin
      Ip.Ttl := char(255);
      Ip.Tos := char(0);
      Ip.IPFlags := char(0);
      Ip.OptSize := char(0);
      Ip.Options := nil;

      dwRetorno := IcmpSendEcho(
        HNDFile,
        Endereco^,
        null,
        0,
        Ip,
        Icmp,
        sizeof(Icmp),
        DWORD(5000));
      Destino.S_addr := icmp.source;
      Memo1.Lines.Add('Pingou ' + Edit1.text);
    end;

  IcmpCLoseHandle(HNDFile);
  FreeLibrary(HNDicmp);
  WSACleanup();
end;

end.