pingBuffer : array [0..31] of AnsiChar;

pingBuffer : array of AnsiChar;

SetLength(pingBuffer, 1452);

sizeof(pingBuffer)

Length(pingBuffer)

pIpe.Data := @pingBuffer;

unit Pings;

interface

USES windows, WinSock, Error;

type

  //TPingParamOut = ();

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

  icmp_echo_reply = packed record
       Address : u_long;                // Адрес отвечающего
       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
 ping_error: DWORD;
 Ping_error_message: string;

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';

function GetPing(HostName: String): Integer;

implementation

function GetPing(HostName: String): Integer;
var
   hIP : THandle;
   pingBuffer : array [0..31] of Char;
   pIpe : ^icmp_echo_reply;
   pHostEn : PHostEnt;
   wVersionRequested : WORD;
   lwsaData : WSAData;
   error : DWORD;
   destAddress : In_Addr;
   ping: Integer;
begin

   // Создаем handle
   hIP    := IcmpCreateFile();
   Result := -1;

   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
     ping_error := error;
     Ping_error_message := 'Error: WSAStartup() to exit; ' + SystemErrorMessage(error);
     //mm.SetTextBuf('Error in call to ' + 'WSAStartup().');
     //mm.Lines.Add('Error code: '+IntToStr(error));
     Exit;
   end;

   pHostEn := gethostbyname(PAnsiChar(AnsiString(HostName)));
   error := GetLastError();
   if (error <> 0) then
   begin
     ping_error := error;
     Ping_error_message := 'Error: gethostbyname() to exit; ' + SystemErrorMessage(error);
     //mm.SetTextBuf('Error in call to' + 'gethostbyname().');
     //mm.Lines.Add('Error code: '+IntToStr(error));
     Exit;
   end;

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

  // Посылаем ping-пакет
  //mm.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),
                500);

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

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

   Result := pIpe.RTTime;
   if Result = 0 then Result := 1;

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

end.

unit ThrPings;

interface

uses
 System.Classes, System.SysUtils , Dialogs, Windows, WinSock, Error;

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

  icmp_echo_reply = packed record
       Address : u_long;                // Адрес отвечающего
       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;

type
 ThreadPings = class(TThread)
 private
   FHostName   : AnsiString;
   FPingResult : Integer;
   FInterval   : Word;
   procedure SetHosName(StrValue: String);
   procedure SetPingResult(IntValue: Integer);
   procedure SetInterval(IntValue: WORD);
   function GetInterval: WORD;
   function GetHostName: String;
   function GetPingResult: Integer;
 protected
   hIP               : THandle;
   pIpe              : ^icmp_echo_reply;
   wVersionRequested : WORD;
   lwsaData          : WSAData;
   pHostEn           : PHostEnt;
   destAddress       : In_Addr;
   error             : DWORD;
   pingBuffer : array [0..31] of Char;
   StrSendText: String;
   procedure SendMemo;
   procedure Execute; override;
 public
   LastErrorMessage: string;
   Property PingResult: Integer read GetPingResult write SetPingResult;
   Property HostName: string read GetHostName write SetHosName;
   Property Interval: WORD read GetInterval write SetInterval;
   procedure Ping;
   constructor Create;
   destructor Destroy; Override;
 end;

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

USES UFrmMain;

constructor ThreadPings.Create;
begin
   inherited Create(True); //CreateSuspended

   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
     LastErrorMessage := 'Error: gethostbyname() ' + SystemErrorMessage(error);
     Terminate;
   end;
end;

destructor ThreadPings.Destroy;
begin
 IcmpCloseHandle(hIP);
 WSACleanup();
 FreeMem(pIpe);
 inherited;
end;

procedure ThreadPings.Execute;
var BgnTime: Cardinal;
begin
 NameThreadForDebugging('TPings');
 { Place thread code here }

 BgnTime := GetTickCount;
 While Not Terminated do
 begin

   if LastErrorMessage <> '' then Continue;

   if ((GetTickCount - BgnTime) div 1000) >= FInterval Then
   begin

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

     error := GetLastError();
     if (error <> 0) then
     begin
       LastErrorMessage := 'Error: IcmpSendEcho() '  + SystemErrorMessage(error);
       Continue;
     end;

     if pIpe.RTTime = 0 then PingResult := 1
     else PingResult := pIpe.RTTime;

     StrSendText := 'Ping: '+IntToStr(PingResult);
     Synchronize(SendMemo);

     BgnTime := GetTickCount;

   end;
   sleep(50);

 end;
end;

function ThreadPings.GetHostName: String;
begin
 Result := FHostName;
end;

function ThreadPings.GetInterval: WORD;
begin
 Result := FInterval;
end;

function ThreadPings.GetPingResult: Integer;
begin
 Result := FPingResult;
end;

procedure ThreadPings.Ping;
begin
 Resume;
end;

procedure ThreadPings.SendMemo;
begin
 FrmMain.mm.lines.add(StrSendText);
end;

procedure ThreadPings.SetHosName(StrValue: String);
begin
 FPingResult      := 0;
 pHostEn := gethostbyname(PAnsiChar(AnsiString(StrValue)));
 error := GetLastError();
 if (error <> 0) then
 begin
   LastErrorMessage := 'Error: gethostbyname() ' + SystemErrorMessage(error);
   ShowMessage(LastErrorMessage);
   Exit;
 end;
 destAddress := PInAddr(pHostEn^.h_addr_list^)^;
 LastErrorMessage := '';
end;

procedure ThreadPings.SetInterval(IntValue: WORD);
begin
 FInterval := IntValue;
 if IntValue < 3 then FInterval := 3;
 if IntValue > 300 then FInterval := 300;
end;

procedure ThreadPings.SetPingResult(IntValue: Integer);
begin
 FPingResult := IntValue;
end;

end.

GetMem(pIpe, sizeof(icmp_echo_reply) + sizeof(pingBuffer));

ThreadPings.Create;

Unit Error;

interface

Uses Windows;

function SystemErrorMessage(ErrorCode: Integer): string;
function GetSysErrorMessage(ErrorCode: Integer): String;
procedure SaveErrorMessage(DebugMsg: String);

var
 LAST_ERROR_MESSAGE : String;

implementation

procedure SaveErrorMessage(DebugMsg: String);
begin
 if DebugMsg <> '' then
   LAST_ERROR_MESSAGE := DebugMsg+' '+GetSysErrorMessage(GetLastError)
 else LAST_ERROR_MESSAGE := GetSysErrorMessage(GetLastError)
end;

{------------------------- GetSysErrorMessage ---------------------------------}
function GetSysErrorMessage(ErrorCode: Integer): String;
Var s: string;
begin
 Str(ErrorCode:0,S);
 Result:='System Error. Code: '+s+' '+SystemErrorMessage(ErrorCode)+'.';
end;

{------------------------- SystemErrorMessage ---------------------------------}
function SystemErrorMessage(ErrorCode: Integer): string;
var
 Buffer : array[0..255] of Char;
 Len    : Integer;
begin
 Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or
                      FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,
                      SizeOf(Buffer), nil);
 while (Len > 0) and (Buffer[Len - 1] in [ #0..#32, '.']) do Dec(Len);
 SetString(Result, Buffer, Len);
end;

end.

var Tpings: ThreadPings;

Tpings := ThreadPings.Create;     // Экземпляр потока создается в спящем режиме
TPings.Interval   := 3;           // здесь задается интервал пингования в секундах, мин. = 3 макс. = 300 секунд
TPings.HostName   := 'Yandex.ru'; // задаем хост для пинга
TPings.Ping;                      // стартуем пингование
TPings.PingResult // получаем ресультат пинга в типе integer если -1 то возникла ошибка ее смотрим TPings.LastErrorMessage, если более 0 то все норм.
mm.Lines.Add('TPings.PingResult: ' + IntToStr(TPings.PingResult)); // читаем результат пинга.