unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type
 ip_option_information = record // Информация заголовка IP (Наполнение 
                            // этой структуры и формат полей описан в RFC791.
     Ttl : u_char;          // Время жизни (используется traceroute-ом)
     Tos : u_char;          // Тип обслуживания, обычно 0
     Flags : u_char;        // Флаги заголовка IP, обычно 0
     OptionsSize : u_char;  // Размер данных в заголовке, обычно 0, максимум 40
     OptionsData : PChar;   // Указатель на данные
 end;


 icmp_echo_reply = record
     Address : DWORD;       // Адрес отвечающего
     Status : u_long;       // IP_STATUS (см. ниже)
     RTTime : u_long;       // Время между эхо-запросом и эхо-ответом
                                            // в миллисекундах
     DataSize : u_short;    // Размер возвращенных данных
     Reserved : u_short;    // Зарезервировано
     Data : Pointer;        // Указатель на возвращенные данные
     Options : ip_option_information; // Информация из заголовка IP
 end;

 PIPINFO = ^ip_option_information;
 PVOID = Pointer;
var
  Form1: TForm1;

 function IcmpCreateFile() : THandle; stdcall; external 'ICMP.DLL' name
                           'IcmpCreateFile';
 function IcmpCloseHandle(IcmpHandle : THandle) : BOOL; stdcall;
                            external 'ICMP.DLL' name 'IcmpCloseHandle';
 function IcmpSendEcho(
   IcmpHandle : THandle;    // handle, возвращенный IcmpCreateFile()
   DestAddress : u_long;    // Адрес получателя (в сетевом порядке)
   RequestData : PVOID;     // Указатель на посылаемые данные
   RequestSize : Word;      // Размер посылаемых данных
   RequestOptns : PIPINFO;  // Указатель на посылаемую структуру
                            // ip_option_information (может быть nil)
   ReplyBuffer : PVOID;     // Указатель на буфер, содержащий ответы.
   ReplySize : DWORD;       // Размер буфера ответов
   Timeout : DWORD          // Время ожидания ответа в миллисекундах
  ) : DWORD; stdcall; external 'ICMP.DLL' name 'IcmpSendEcho';


implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
    hIP : THandle;
    pingBuffer : array [0..31] of Char;
    pIpe : ^icmp_echo_reply;
    pHostEn : PHostEnt;
    wVersionRequested : WORD;
    lwsaData : WSAData;
    error : DWORD;
    destAddress : In_Addr;
begin
// Создаем handle
    hIP := IcmpCreateFile();

    GetMem( pIpe,
            sizeof(icmp_echo_reply) + sizeof(pingBuffer));
    pIpe.Data := @pingBuffer;
    pIpe.DataSize := sizeof(pingBuffer);

    wVersionRequested := MakeWord(1,1);
    error := WSAStartup(wVersionRequested,lwsaData);
    if (error <> 0) then
    begin
         Memo1.SetTextBuf('Error in call to '+
                          'WSAStartup().');
         Memo1.Lines.Add('Error code: '+IntToStr(error));
         Exit;
    end;

    pHostEn := gethostbyname('www.perm.ru');
    error := GetLastError();
    if (error <> 0) then
    begin
         Memo1.SetTextBuf('Error in call to'+
                          'gethostbyname().');
         Memo1.Lines.Add('Error code: '+IntToStr(error));
         Exit;
    end;

    destAddress := PInAddr(pHostEn^.h_addr_list^)^;

    // Посылаем ping-пакет
    Memo1.Lines.Add('Pinging ' +
                    pHostEn^.h_name+' ['+
                    inet_ntoa(destAddress)+'] '+
                    ' with '+
                    IntToStr(sizeof(pingBuffer)) +
                    ' bytes of data:');

    IcmpSendEcho(hIP,
                 destAddress.S_addr,
                 @pingBuffer,
                 sizeof(pingBuffer),
                 Nil,
                 pIpe,
                 sizeof(icmp_echo_reply) + sizeof(pingBuffer),
                 5000);

    error := GetLastError();
    if (error <> 0) then
    begin
         Memo1.SetTextBuf('Error in call to'+
                          'IcmpSendEcho()');
         Memo1.Lines.Add('Error code: '+IntToStr(error));
         Exit;
    end;

    // Смотрим некоторые из вернувшихся данных
    Memo1.Lines.Add('Reply from '+
                IntToStr(LoByte(LoWord(pIpe^.Address)))+'.'+
                IntToStr(HiByte(LoWord(pIpe^.Address)))+'.'+
                IntToStr(LoByte(HiWord(pIpe^.Address)))+'.'+
                IntToStr(HiByte(HiWord(pIpe^.Address))));
    Memo1.Lines.Add('Reply time: '+IntToStr(pIpe.RTTime)+' ms');

    IcmpCloseHandle(hIP);
    WSACleanup();
    FreeMem(pIpe);

end;

end.
