Маааленькое 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.
--------------------------------------------