Delphi的ping源程序

unit ping;

 

interface

 

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs,winsock,

  StdCtrls, Grids;

type

PIPOptionInformation=^TIPOptionInformation;

TIPOptionInformation = packed record

TTL: Byte;

TOS: Byte;

Flags: Byte;

OptionsSize: Byte;

OptionsData: PChar;

end;

type 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;RequestDa

ta: Pointer;RequestSize: Word;RequestOptions: PIPOptionInformation;ReplyBuffer

: Pointer;ReplySize: DWord;Timeout: DWord): DWord; stdcall;

type

Tfrmping = class(TForm)

    echogrid: TStringGrid;

    ipaddr: TEdit;

    Label1: TLabel;

    ping: TButton;

procedure FormCreate(Sender: TObject);

    procedure pingClick(Sender: TObject);

    procedure FormDestroy(Sender: TObject);

private

hICMP: THANDLE;

IcmpCreateFile : TIcmpCreateFile;

IcmpCloseHandle:TIcmpCloseHandle;

IcmpSendEcho: TIcmpSendEcho;

line:integer;

{ Private declarations }

public

hICMPdll: HMODULE;{ Public declarations }

end;

 

var

  frmping: Tfrmping;

 

implementation

 

{$R *.DFM}

 

procedure Tfrmping.FormCreate(Sender: TObject);

begin

hICMPdll := LoadLibrary('icmp.dll');

@ICMPCreateFile:= GetProcAddress(hICMPdll, 'IcmpCreateFile');

@IcmpCloseHandle := GetProcAddress(hICMPdll, 'IcmpCloseHandle');

@IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');

hICMP := IcmpCreateFile;

echogrid.Cells[0,0]:='返回地址';

echogrid.cells[1,0]:='返回数据包大小';

echogrid.Cells[2,0]:='状态';

echogrid.Cells[3,0]:='RTT(Round-Trip-Time)';

line:=1;

end;

 

procedure Tfrmping.pingClick(Sender: TObject);

var

IPOpt:TIPOptionInformation;// IP Options for packet to send

FIPAddress:DWORD;

pReqData,pRevData:PChar;

pIPE:PIcmpEchoReply;// ICMP Echo reply buffer

FSize: DWORD;

MyString:string;

FTimeOut:DWORD;

BufferSize:DWORD;

begin

if iPaddr.Text <> '' then

begin

FIPAddress:=inet_addr(PChar(ipaddr.Text));

if Fipaddress=INADDR_NONE then Messagebox(self.handle,'地址无效

','Ping32',64)

else

begin

FSize:=40;

BufferSize:=SizeOf(TICMPEchoReply)+FSize;

GetMem(pRevData,FSize);

GetMem(pIPE,BufferSize);

FillChar(pIPE^, SizeOf(pIPE^), 0);

pIPE^.Data := pRevData;

MyString := 'Argen Ping32 Sending Message.';

pReqData := PChar(MyString);

FillChar(IPOpt, Sizeof(IPOpt), 0);

IPOpt.TTL:= 64;

FTimeOut :=10000;

IcmpSendEcho(hICMP, FIPAddress, pReqData, Length(MyString),@IPOpt, pIPE,

BufferSize, FTimeOut);

try

try

if pReqData^ = pIPE^.Options.OptionsData^ then

with echogrid do

begin

if line>1 then rowcount:=line+1;

cells[0,line]:=ipaddr.Text;

cells[1,line]:=inttoStr(pIPE^.DataSize);

cells[3,line]:=IntToStr(pIPE^.RTT);

row:=rowcount-1;

line:=line+1;

end;

except

Messagebox(self.handle,'目标不可到','Ping32',64)

end;

finally

FreeMem(pRevData);

FreeMem(pIPE);

end;

end;

end;

end;

procedure Tfrmping.FormDestroy(Sender: TObject);

begin

icmpclosehandle(hicmp);

freelibrary(hicmpdll);

end;

 

end.