知道对方IP，怎样在程序里确认对方是否在线？

[vccomputer]

知道对方IP，怎样在程序里确认对方是否在线？
如果用Ping的话，怎样在程序里实现，多谢了!

[qiume]

调用API

[wisenowa]

//ping

unit PING;

interface

uses WinSock, Types, Windows, Classes, SysUtils;

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;

TPingParam = record
H: THandle;
Msg: integer;

PingIP: string;
TimeOut: integer;
PingTimes: integer;
end;

TPingThread = class(TThread)
private
FIP: DWORD;
FIPStr: string;
FTimeOut: integer;
FFormHandle: THandle;
FMsg: integer;
FPingTimes: integer;

protected
procedure Execute; override;
public
constructor Create(PingParam: TPingParam;
RsltStrings: TStrings);
destructor Destroy; override;
end;

implementation

var
ICMPHandle: HMODULE;
ICMPCreateFile : TIcmpCreateFile;
ICMPCloseHandle: TIcmpCloseHandle;
ICMPSendEcho: TIcmpSendEcho;

function LoadICMPDll: boolean;
begin
ICMPHandle := LoadLibrary('icmp.dll');
if ICMPHandle = 0 then
Result := False
else
begin
@ICMPCreateFile := GetProcAddress(ICMPHandle, pchar('IcmpCreateFile'));
@ICMPCloseHandle := GetProcAddress(ICMPHandle, pchar('IcmpCloseHandle'));
@ICMPSendEcho := GetProcAddress(ICMPHandle, pchar('IcmpSendEcho'));
Result := True;
end;
end;

procedure UnLoadICMP;
begin
if ICMPHandle <> 0 then
FreeLibrary(ICMPHandle);
end;

{ TPingTHread }

{ TPingTHread }

constructor TPingTHread.Create(PingParam: TPingParam; RsltStrings: TStrings);
var
WSAData: TWSAData;
// Phe : PHostEnt;
begin
Inherited Create(False);
if WSAStartup($101, WSAData) <> 0 then
Terminate;
if not LoadICMPDll then
Terminate;
FIPStr := PingParam.PingIP;
FIP := inet_addr(pchar(PingParam.PingIP));
{ if FIP = INADDR_NONE then
begin
Phe := GetHostByName(PChar(PingParam.PingIP));
if Phe = nil then
begin
raise Exception.Create('Unknow Host!');
Terminate;
end else
FIP := longint(plongint(Phe^.h_addr_list^)^);
end; }

FTimeOut := PingParam.TimeOut;
FFormHandle := PingParam.H;
FMsg := PingParam.Msg;
FPingTimes := PingParam.PingTimes;
FreeOnTerminate := True;
end;

destructor TPingTHread.Destroy;
begin
ICMPCloseHandle(ICMPHandle);
WSACleanUp;
UnLoadICMP;
inherited;
end;

procedure TPingTHread.Execute;
var
IPOpt: TIPOptionInformation; // IP Options for packet to send
pReqData, pRevData: PChar;
pIPE: PIcmpEchoReply; // ICMP Echo reply buffer
DataSize: DWORD;
StrToSend: string;
BufSize: DWORD;
HICMP: THandle;
StrMsg: string;
n: integer;
IsThere: integer; // 是否ping通
begin
inherited;
DataSize := 40;
BufSize := SizeOf(TICMPEchoReply) + DataSize;
GetMem(pRevData, DataSize);
GetMem(pIPE, BufSize);
FillChar(pIPE^, SizeOf(pIPE^), 0);
pIPE^.Data := pRevData;
StrToSend := 'Hello,WorldAAAAA';
pReqData := PChar(StrToSend);
FillChar(IPOpt, Sizeof(IPOpt), 0);
IPOpt.TTL := 64;
HICMP := ICMPCreateFile;
try
for n := 1 to FPingTimes do
begin
ICMPSendEcho(HICMP, FIP, pReqData, Length(StrToSend), @IPOpt, pIPE, BufSize, FTimeOut);
try
if pReqData^ = pIPE^.Options.OptionsData^ then
begin
StrMsg := 'Reply from ' + FIPStr + ': bytes=' + IntToStr(pIPE^.DataSize)
+ ' TTL=' + IntToStr(pIPE^.RTT);
IsThere := 1;
end else
begin
StrMsg := 'Time out from ' + FIPStr;
IsThere := 0;
end;
except
StrMsg := 'Time out from ' + FIPStr;
IsThere := 0;
end;

PostMessage(FFormHandle, FMsg, integer(pchar(StrMsg)), IsThere);
end;
finally
FreeMem(PRevData);
FreeMem(pIPE);
end;
end;

end.
------------------------------
unit uMain;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;

const
WM_PING = WM_USER + $1024;

type
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
Edit1: TEdit;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
procedure WMPing(var Msg: TMessage); message WM_PING;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

uses PING;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
P: TPingParam;
begin
P.H := Handle;
p.Msg := WM_PING;
p.PingIP := Edit1.Text;
P.TimeOut := 4000;
p.PingTimes := 4;
Memo1.Lines.Add('--------------------------------------------------------');
Memo1.Lines.Add('Ping ' + Edit1.Text + ' ...');
TPingThread.Create(P, nil);
end;

procedure TForm1.WMPing(var Msg: TMessage);
var
Str: string;
begin
if Msg.LParam = 0 then
Str := '不通'
else
Str := '通';
Memo1.Lines.Add(pchar(Msg.WParam) + Str);
end;

end.

[hydonlee]

Delphi6以上有现成的Icmp控件。

[jiangshi99]

学习中……

[hansion3406]

好像看过...