Реализация 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.

тема на форуме

Похожие статьи

• Ping из VBA
• Ping на Delphi
• TPLink TD-8840T. Аппаратный NAT.