Delphi中PING的实现

fjwolf 2009-03-19

展开全文

Delphi中PING的实现

2008-08-08 20:09

调用: Uses Ping;

procedure TForm1.Button1Click(Sender:TObject);
var
str:string;
ping:Tping;
begin
ping := Tping.create; //一定要初试化哦
ping.pinghost('192.168.1.152', str);
memo1.Lines.Add(str);
if str = 'Can not find host!' then ShowMessage('该主机当前不在线!');
ping.destroy;
end;

====[ping.pas]=====

unit ping;

interface

uses

Windows, SysUtils, Classes, Controls, Winsock,
StdCtrls;

type
PIPOptionInformation = ^TIPOptionInformation;
TIPOptionInformation = packed record
    TTL:Byte;
    TOS:Byte;
    Flags:Byte;
    OptionsSize:Byte;
    OptionsData:PChar;
end;

PIcmpEchoReply = ^TIcmpEchoReply;
TIcmpEchoReply = packed record
    Address:DWORD;
    Status:DWORD;
    RTT:DWORD;
    DataSize:Word;
    Reserved:Word;
    Data:Pointer;
    Options:TIPOptionInformation;
end;

TIcmpCreateFile = function:THandle; stdcall;
TIcmpCloseHandle = function(IcmpHandle:THandle):Boolean; stdcall;
TIcmpSendEcho = function(IcmpHandle:THandle;
    DestinationAddress:DWORD;
    RequestData:Pointer;
    RequestSize:Word;
    RequestOptions:PIPOptionInformation;
    ReplyBuffer:Pointer;
    ReplySize:DWord;
    Timeout:DWord
    ):DWord; stdcall;

Tping = class(Tobject)

private
    { Private declarations }
    hICMP:THANDLE;
    IcmpCreateFile:TIcmpCreateFile;
    IcmpCloseHandle:TIcmpCloseHandle;
    IcmpSendEcho:TIcmpSendEcho;
public
    procedure pinghost(ip:string; var info:string);
    constructor create;
    destructor destroy; override;
    { Public declarations }
end;

var
hICMPdll:HMODULE;

implementation

constructor Tping.create;
begin
inherited create;
hICMPdll := LoadLibrary('icmp.dll');
@ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');
@IcmpCloseHandle := GetProcAddress(hICMPdll, 'IcmpCloseHandle');
@IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');
hICMP := IcmpCreateFile;
end;

destructor Tping.destroy;
begin
FreeLibrary(hIcmpDll);
inherited destroy;
end;

procedure Tping.pinghost(ip:string; var info:string);
var
// IP Options for packet to send
IPOpt:TIPOptionInformation;
FIPAddress:DWORD;
pReqData, pRevData:PChar;
// ICMP Echo reply buffer
pIPE:PIcmpEchoReply;
FSize:DWORD;
MyString:string;
FTimeOut:DWORD;
BufferSize:DWORD;
begin

if ip <> '' then
begin
    FIPAddress := inet_addr(PChar(ip));
    FSize := 40;
    BufferSize := SizeOf(TICMPEchoReply) + FSize;
    GetMem(pRevData, FSize);
    GetMem(pIPE, BufferSize);
    FillChar(pIPE^, SizeOf(pIPE^), 0);
    pIPE^.Data := pRevData;
    MyString := 'Test Net - Sos Admin';
    pReqData := PChar(MyString);
    FillChar(IPOpt, Sizeof(IPOpt), 0);
    IPOpt.TTL := 64;
    FTimeOut := 100;
    try
      IcmpSendEcho(hICMP, FIPAddress, pReqData, Length(MyString), @IPOpt, pIPE,
        BufferSize, FTimeOut);
      if pReqData^ = pIPE^.Options.OptionsData^ then
        info := ip + '　' + IntToStr(pIPE^.DataSize) + '　　　' +
          IntToStr(pIPE^.RTT);
    except
      info := 'Can not find host!';
      FreeMem(pRevData);
      FreeMem(pIPE);
      Exit;
    end;
    FreeMem(pRevData);
    FreeMem(pIPE);
end;
end;