//返回的Ping一个Url所需时间 //需要一个TCPClient组件,再NetFast里面 function TThreadPing.PingHost(Url:String):String; var Str:String; i:Integer; BefTime,AftTime:TTime; Hour, Min, Sec, MSec: Word; S:String; R:real;begin R:=0; Str:=Url; if StrLower(Pchar(Copy(Url,1,3)))='htt' then begin Str:=Copy(Url,8,Length(Url)); Str:=Copy(Str,1,Pos('/',Str)-1); end else if StrLower(Pchar(Copy(Url,1,3)))='ftp' then begin Str:=Copy(Url,7,Length(Url)); Str:=Copy(Str,1,Length(Str)-Pos(Str,'/')); end; for i := 1 to 4 do with FTCPClient do begin BefTime:=Now; RemoteHost:=Str; RemotePort:='80'; try Connect; try AftTime:=Now; DecodeTime(AftTime-BefTime, Hour, Min, Sec, MSec); R:=Sec+MsEc/1000; finally Disconnect; end; except on E: Exception do R:=-1; end; end;result:=Format('%.3f',[R]); end;
好象不太聪明啊
用IdIcmpClient1.Ping试试看
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.
很多书上都有的
//需要一个TCPClient组件,再NetFast里面
function TThreadPing.PingHost(Url:String):String;
var
Str:String;
i:Integer;
BefTime,AftTime:TTime;
Hour, Min, Sec, MSec: Word;
S:String;
R:real;begin
R:=0;
Str:=Url; if StrLower(Pchar(Copy(Url,1,3)))='htt' then
begin
Str:=Copy(Url,8,Length(Url));
Str:=Copy(Str,1,Pos('/',Str)-1);
end
else
if StrLower(Pchar(Copy(Url,1,3)))='ftp' then
begin
Str:=Copy(Url,7,Length(Url));
Str:=Copy(Str,1,Length(Str)-Pos(Str,'/'));
end;
for i := 1 to 4 do
with FTCPClient do
begin
BefTime:=Now;
RemoteHost:=Str;
RemotePort:='80';
try
Connect;
try
AftTime:=Now;
DecodeTime(AftTime-BefTime, Hour, Min, Sec, MSec);
R:=Sec+MsEc/1000;
finally
Disconnect;
end;
except on E: Exception do
R:=-1; end;
end;result:=Format('%.3f',[R]);
end;
var
buf : String;
begin
Buf := 'Hello';
IdIcmpClient1.host := 'pop.163.com';
IdIcmpClient1.Port := 110;
IdIcmpClient1.Ping(buf,1000);
Memo1.Lines.Add('After Ping : ' + buf);
end;procedure TForm1.IdIcmpClient1Reply(ASender: TComponent;
const AReplyStatus: TReplyStatus);
begin
Memo1.Lines.Add( AReplyStatus.FromIpAddress);
end;
好, 我补充一下.
我用的是IdIcmpClient1控件来实现Ping的功能.
在窗体上放一个IdIcmpClient1, 一个Memo和一个Button,
在Button写入以上代码1.进行Ping.
在IdIcmpClient1的OnReply事件中写入第二段代码.(如果有返回, 则加入Memo中)
Wnyu(西门吹水) 好
unit UMethods;interface
uses
IdIcmpClient, WinInet;
function ping(const url: string):boolean;implementationfunction ping(const url: string):boolean;
var
aIdICMPClient: TIdICMPClient;
begin
Result:= True;
aIdICMPClient:= TIdICMPClient.Create(nil);
aIdICMPClient.Host:= url;
try
aIdICMPClient.Ping();
except
Result:= False;
end;
aIdICMPClient.Free;
end;end.