Не, ну это не серьезно...
Надо так!
Код:
unit icmp;
interface
uses jwaICMPAPI, jwaIPExport, jwaWinsock2, SysUtils, jwaWinError;
resourcestring
stHostNotFound = 'Не удалось обнаружить узел';
stERRORINVALIDPARAMETER = 'Неверный параметр';
stERRORNOTENOUGHMEMORY = 'Недостаточно памяти для завершения операции';
stERRORUnknown = 'Неизвестная ошибка';
const
BaseStatus = 11000;
StatusString: array[0..18] of string =
('The status was success',
'The reply buffer was too small',
'Заданная сеть недоступна',
'The destination host was unreachable',
'The destination protocol was unreachable',
'The destination port was unreachable',
'Insufficient IP resources were available',
'A bad IP option was specified',
'A hardware error occurred',
'Слишком большая длинна пакета',
'Превышен интервал ожидания для запроса',
'A bad request',
'A bad route',
'The time to live (TTL) expired in transit',
'The time to live expired during fragment reassembly',
'A parameter problem',
'Datagrams are arriving too fast to be processed and datagrams may have been discarded',
'An IP option was too big',
'Указан неправильный адрес');
type TPing = class(TObject)
private
fIcmpHandle: THandle;
fIPINFO: TIPOPTIONINFORMATION;
fReply: TICMPECHOREPLY;
fHostName: string;
fHostIP: LONGWORD;
fTTL: byte;
fTOS: byte;
fPacketLen: LONGWORD;
fTimeWait: LONGWORD;
FFragmented: boolean;
fErrString: string;
FReplyBufSize: LONGWORD;
pReqData: pointer;
pData: pointer;
pEchoReply: PICMPECHOREPLY;
function GetHostName: string;
procedure SetHostName(const Value: string);
function GetIPFromName(AName: string): LONGWORD;
public
constructor Create();
destructor Destroy; override;
function Ping: integer;
procedure Free;
property HostName: string read GetHostName write SetHostName;
property TTL: byte read fTTL write fTTL;
property TOS: byte read fTOS write fTOS;
property TimeWait: LONGWORD read fTimeWait write fTimeWait;
property ErrorString: string read FErrString;
property Fragmented: boolean read FFragmented Write FFragmented;
property Reply: TICMPECHOREPLY read FReply;
property PacketLen: LONGWORD read FPacketLen write FPacketLen;
end;
implementation
{ TPing }
constructor TPing.Create;
begin
inherited;
FIcmpHandle := IcmpCreateFile();
FTTL := 128;
FTOS := 0;
FPacketLen := 32;
FTimeWait := 1000;
FErrString := '';
FFragmented := true;
FHostIP := 0;
end;
destructor TPing.Destroy;
begin
IcmpCloseHandle(fIcmpHandle);
end;
procedure TPing.Free;
begin
if Self <> nil then Destroy;
end;
function TPing.GetHostName: string;
begin
Result := FHostName;
end;
function TPing.GetIPFromName(AName: string): LONGWORD;
var
Host: PHostEnt;
WSADATA: TWSADATA;
s: AnsiString;
begin
Result := 0;
s := aName;
WSAStartup(WINSOCK_VERSION, WSADATA);
Host := GetHostByName(PAnsiChar(s));
if Host <> nil then
Result := LONGINT(pLONGINT(Host^.h_addr_list^)^);
WSACleanup();
end;
function TPing.Ping: integer;
begin
Result := 0;
if FHostIP = 0 then begin
Result := -1;
FErrString := stHostNotFound;
end;
FReplyBufSize := SizeOf(TICMPECHOREPLY) + FPacketLen;
GetMem(pReqData, FPacketLen);
GetMem(pData, FPacketLen);
GetMem(pEchoReply, FReplyBufSize);
FillChar(pReqData^, FPacketLen, 0);
FillChar(pEchoReply^, SizeOf(pEchoReply^),0);
FillChar(FIPINFO, SizeOf(TIPOPTIONINFORMATION),0);
pEchoReply.Data := pData;
with FIPINFO do begin
TTL := FTTL;
TOS := FTOS;
OptionsSize := 0;
OptionsData := nil;
if FFragmented then Flags := 0
else Flags := 2;
end;
{Ф-ия IcmpEchoReply возвращает 0 в случае НЕУДАЧИ!
В противном случае возвращает кол-во записей типа TIcmpEchoReply
}
if IcmpSendEcho(FIcmpHandle, FHostIP, pReqData, FPacketLen,
@FIPINFO, pEchoReply, FReplyBufSize, FTimeWait) = 0
then begin
Result := -1;
case GetLastError of
ERROR_INVALID_PARAMETER: FErrString := STERRORINVALIDPARAMETER;
ERROR_NOT_ENOUGH_MEMORY: FErrString := stERRORNOTENOUGHMEMORY;
ERROR_NOT_SUPPORTED : FErrString := stERRORUnknown;
else
begin
if pEchoReply^.Status <> 0 then
fErrString := StatusString[pEchoReply^.Status - BaseStatus];
Result := pEchoReply^.Status;
end;
end;//case..else
FreeMem(pReqData);
FreeMem(pEchoReply);
FreeMem(pData);
Exit;
end;//if..then
FReply := pEchoReply^;
if pEchoReply^.Status <> 0 then
begin
FErrString := StatusString[pEchoReply^.Status - BaseStatus];
Result := pEchoReply^.Status - BaseStatus;
end;
FreeMem(pReqData);
FreeMem(pEchoReply);
FreeMem(pData);
end;//function Ping
procedure TPing.SetHostName(const Value: string);
begin
FHostName := Value;
FHostIP := GetIPFromName(Value);
end;
end.