Справочник функций

Ваш аккаунт

Войти через: 
Забыли пароль?
Регистрация
Информацию о новых материалах можно получать и без регистрации:

Последние темы форума

Показать новые сообщения »

Почтовая рассылка

Подписчиков: 11656
Последний выпуск: 19.06.2015

Пингуем (Ping) под Delphi

Пингуем (Ping) под Delphi

Протокол 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. 

Оставить комментарий

Комментарий:
можно использовать BB-коды
Максимальная длина комментария - 4000 символов.
 

Комментарии

1.
40K
03 июня 2008 года
soffa
1 / / 03.06.2008
Мне нравитсяМне не нравится
3 июня 2008, 11:49:59
а можно сий код переделать так, чтобы пинг шел постоянно, с интервалом в несколько секунд, и если пинг становится быстрее определенного значения, то отрубается подключение LAN?
получицца клевая прога, позволяющая съэкономить деньги при использовании спутник + адсл.
я сам не программист, такчто сий код для меня темный лес, но если кто-нить реализует, куча народу спасибо скажет
2.
39K
17 апреля 2008 года
Kayfolom
0 / / 17.04.2008
Мне нравитсяМне не нравится
17 апреля 2008, 18:03:44
Много кода, запутанно и загадочно ;) Особенно учесть что код ничего не делает ;)
Особенно умиляет Memo1.Lines.Add('Pingou ' + Edit1.text); в цикле в конце. В таком варианте он пингует все, и от всего приходит ответ. Проще было сделать так:
procedure TForm1.Button1Click(Sender: TObject);
Var x : Integer;
begin
memo1.Lines.Add('Pinging ' + Edit1.text);
for x:= 0 to 4 do
Memo1.Lines.Add('Pingou ' + Edit1.text);
end;
Этот код работает стольже эффективно ;)
3.
Аноним
+0 / -1
Мне нравитсяМне не нравится
12 апреля 2006, 20:15:17
Код неплохой, вот только он локальные айпи не видит совсем...
4.
Аноним
+0 / -2
Мне нравитсяМне не нравится
8 ноября 2005, 22:57:40
Как раз то что исчу :)
Реклама на сайте | Обмен ссылками | Ссылки | Экспорт (RSS) | Контакты
Добавить статью | Добавить исходник | Добавить хостинг-провайдера | Добавить сайт в каталог