unit Unit14;

interface

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

type
  TPingForm = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Edit1: TEdit;
    Label1: TLabel;
    Edit2: TEdit;
    Label2: TLabel;
    CheckBox1: TCheckBox;
    Edit3: TEdit;
    Label3: TLabel;
    procedure FormCreate(Sender: TObject);
    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
  PingForm: TPingForm;

 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';
 var PingError :integer;
implementation

{$R *.dfm}
procedure Ping;
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
with PingForm do
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
      if not CheckBox1.Checked then
       begin
         Memo1.Lines.Add('Error in call to '+
                          'WSAStartup().');
         Memo1.Lines.Add('Error code: '+IntToStr(error));
         Inc(PingError);
         Exit;
       End;
    end;

    pHostEn := gethostbyname(pchar(Edit1.text));
    error := GetLastError();
    if (error <> 0) then
    begin
      if not CheckBox1.Checked then
      begin
         Memo1.Lines.Add('Error in call to'+
                          'gethostbyname().');
         Memo1.Lines.Add('Error code: '+IntToStr(error));
         Inc(PingError);
         Exit;
      end;
    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
       if Not CheckBox1.Checked then
         begin
         Memo1.Lines.Add('Error in call to'+
                          'IcmpSendEcho()');
         Memo1.Lines.Add('Error code: '+IntToStr(error));
          Inc(PingError);
         Exit;
         end;
    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;




procedure TPingForm.FormCreate(Sender: TObject);
begin
Memo1.Clear;
Edit1.Text:='SlaUr.Perm.ru';
Edit2.Text:='5';
Edit3.Text:='100';
end;

procedure TPingForm.Button1Click(Sender: TObject);
var i1:integer;
begin
memo1.Clear;
PingError:=0;
For i1:=1 to StrToInt(Edit2.Text)do
begin
Memo1.Lines.Add(IntToStr(i1)+'----------------------------------------------------------------------------------');
ping;
Sleep(StrToInt(Edit3.Text));
End;
if CheckBox1.Checked then Memo1.Lines.Add('--------- Ошибок : '+IntToStr(PingError)+'-------------');


end;

end.

