谁有Ping的Delphi源程序？给我一份.

Question

谁有Ping的Delphi源程序？给我一份.

Answer 1

{
用 Delphi实现ping的例子
[email protected]
}
unit PingUnit;interfaceuses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls,winsock;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;
phe: pHostent;
 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;
 TPingForm = class(TForm)
    StatusShow: TMemo;
    Panel1: TPanel;
    pingedit: TEdit;
    exebutton: TButton;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure exebuttonClick(Sender: TObject);
  private
    { Private declarations } hICMP: THANDLE;
 IcmpCreateFile : TIcmpCreateFile;
 IcmpCloseHandle: TIcmpCloseHandle;
 IcmpSendEcho: TIcmpSendEcho;
  public
    { Public declarations }
  end;var
  PingForm: TPingForm;  HostName:string;implementation{$R *.DFM}procedure TPingForm.FormCreate(Sender: TObject);
 var
  WSAData: TWSAData;
  hICMPdll: HMODULE;
 begin
   wsastartup($101,wsadata);
   hICMPdll := LoadLibrary('icmp.dll');
   @ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');
   @IcmpCloseHandle := GetProcAddress(hICMPdll, 'IcmpCloseHandle');
   @IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');
   hICMP := IcmpCreateFile;
   StatusShow.Text := '';
   statusshow.Align := alclient;
   StatusShow.Lines.Add('目的IP地址 字节数 返回时间(毫秒)');
 end;
procedure TPingForm.exebuttonClick(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;
     IcmpSendEcho(hICMP, FIPAddress, pReqData, Length(MyString), @IPOpt, pIPE, BufferSize, FTimeOut);
      try
       if pReqData^ = pIPE^.Options.OptionsData^ then
           begin
             StatusShow.Lines.Add(PChar(PingEdit.Text) + '      ' +IntToStr(pIPE^.DataSize) + '      ' +IntToStr(pIPE^.RTT));
           end;
        except
        messagedlg('没有找到该IP地址!',mtinformation,[mbok],0);
        end;
     pIPE^.Phe := GetHostByAddr(@FIPAddress, 4, AF_INET);
     if pIPE^.Phe <> Nil   then HostName:=pIPE^.Phe^.h_name;
     caption:=hostname;
     FreeMem(pRevData);
     FreeMem(pIPE);
    end;
 end;end.