![](/logo_grey.gif)
Последние записи
- Сравнение языков на массивах. Часть 2
- wprintf как напечатать кириллицу
- Взаимодействие через командную строку
- Сравнение языков на массивах. Часть 1
- Сравнение языков по скорости
- Чтение огромных xml-файлов
- Как в Python+Selenium webdriver открыть новую вкладку в уже открытом браузере?
- Lazarus, проверка существования строки таблице
- BASM и record, обращение к полям записи
- Web PHP Framework Symfony
![](http://programmersclub.ru/slurm3.jpg)
Интенсив по Python: Работа с API и фреймворками 24-26 ИЮНЯ 2022. Знаете Python, но хотите расширить свои навыки?
Slurm подготовили для вас особенный продукт! Оставить заявку по ссылке - https://slurm.club/3MeqNEk
![](http://programmersclub.ru/katajpg.jpg)
Online-курс Java с оплатой после трудоустройства. Каждый выпускник получает предложение о работе
И зарплату на 30% выше ожидаемой, подробнее на сайте академии, ссылка - ttps://clck.ru/fCrQw
11th
Сен
Реализация ping в Delphi
Posted by obzor under Delphi
Хочу написать программу, что бы пинговать компьютер и в окне видеть надпись » компьютер в сети».
Реализация класса TPing
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.
Похожие статьи
Купить рекламу на сайте за 1000 руб
пишите сюда - alarforum@yandex.ru
Да и по любым другим вопросам пишите на почту
![пеллетные котлы](http://programmersclub.ru/respective.jpg)
пеллетные котлы
![пеллетный котел](http://programmersclub.ru/emtas.jpg)
Пеллетный котел Emtas
![форум программистов](http://programmersclub.ru/banf336х280.gif)
Наши форумы по программированию:
- Форум Web программирование (веб)
- Delphi форумы
- Форумы C (Си)
- Форум .NET Frameworks (точка нет фреймворки)
- Форум Java (джава)
- Форум низкоуровневое программирование
- Форум VBA (вба)
- Форум OpenGL
- Форум DirectX
- Форум CAD проектирование
- Форум по операционным системам
- Форум Software (Софт)
- Форум Hardware (Компьютерное железо)