回复人：guoyuzhang(怒抛头颅)　(2001-3-19 19:01:00)  得0分

ping程序

unit Unit1;

interface

uses

 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 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;

 TForm1 = class(TForm)

   Memo1: TMemo;

   Button1: TButton;

   PingEdit: TEdit;

   procedure FormCreate(Sender: TObject);

   procedure Button1Click(Sender: TObject);

 private

   { Private declarations }

   hICMP: THANDLE;

   IcmpCreateFile : TIcmpCreateFile;

   IcmpCloseHandle: TIcmpCloseHandle;

   IcmpSendEcho: TIcmpSendEcho;

 public

   { Public declarations }

 end;

var

 Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

var

 hICMPdll: HMODULE;

begin

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

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

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

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

 hICMP := IcmpCreateFile;

 Memo1.Text := '';

 Memo1.Lines.Add('目的IP地址 字节数 返回时间(毫秒)');

end;

procedure TForm1.Button1Click(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 PingEdit.Text <> '' then

   begin

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

         FSize := 40;

         BufferSize := SizeOf(TICMPEchoReply) + FSize;

         GetMem(pRevData,FSize);

         GetMem(pIPE,BufferSize);

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

         pIPE^.Data := pRevData;

         MyString := 'Hello,World';

         pReqData := PChar(MyString);

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

         IPOpt.TTL := 64;

         FTimeOut := 4000;

         try

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

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

             Memo1.Lines.Add(PChar(PingEdit.Text) + ' ' + IntToStr(pIPE^.DataSize) + ' ' +IntToStr(pIPE^.RTT));

         except

             Memo1.Lines.Add('Cant resolve host!');

             FreeMem(pRevData);

             FreeMem(pIPE);

             Exit;

         end;

         FreeMem(pRevData);

         FreeMem(pIPE);

   end;

end;

end.