Delphi World - Маааленькое PING-приложеньице

Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...

Маааленькое PING-приложеньице

Два интеpнетчика:
- Попингуй!
- От попингуя слышу.

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

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

Запускаем Delphi;
В Новом проекте добавляем в форму Tbutton, Tedit и Tmemo;
Вставляем “winsock”;
объявляем структурку для IP-заголовка:

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

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

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

Объявляем функции и процедуры, которые мы будем вызывать из 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}

В 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
    Host := GetHostbyName(PChar(Edit1.text))
  else
    Host := GetHostbyAddr(@Destino,sizeof(in_addr), AF_INET);

  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.

Это всё…..

Ну и в конце полный исходный код примера можно взять здесь.