Delphi ping atma hakkında

[ByTEK]

Merhaba arkadaşlar,

kendim için bir uygulama yapıyorum ve belirli aralıklarda ping atarak cihazın networkte olup olmadığını tespit ediyorum. Aşağıdaki kütüphaneyi kullanmak istiyorum. Fakat lazarus ve delphide çalışmadı. sonuç geriye boş yada time out dönüyor. indy icmpclient kullandığım zaman eğer makine ağda yoksa evap gelene kadar uygulama kasıyor. thread ile çözdüğümde bu seferde farklı ip lere timer ile çalıştırınca sıkıntı oluyor. Aşağıdaki lib kullanmak istiyorum.

unit ping;

interface

uses

Windows, SysUtils, Classes,  Controls, Winsock,
StdCtrls;

function pingip(ip:string):string;

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;

Tping =class(Tobject)

private
{ Private declarations }
hICMP: THANDLE;
IcmpCreateFile : TIcmpCreateFile;
IcmpCloseHandle: TIcmpCloseHandle;
IcmpSendEcho: TIcmpSendEcho;
public
procedure   pinghost(ip:string;var info:string);
constructor create;
destructor destroy;override;
{ Public declarations }
end;

var
hICMPdll: HMODULE;

implementation

constructor Tping.create;
begin
inherited create;
hICMPdll := LoadLibrary('icmp.dll');
@ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');
@IcmpCloseHandle := GetProcAddress(hICMPdll,'IcmpCloseHandle');
@IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');
hICMP := IcmpCreateFile;
end;

destructor Tping.destroy;
begin
FreeLibrary(hIcmpDll);
inherited destroy;
end;


procedure Tping.pinghost(ip:string;var info:string);
var
// IP Options for packet to send
IPOpt:TIPOptionInformation;
FIPAddress:DWORD;
pReqData,pRevData:PChar;
// ICMP Echo reply buffer
pIPE:PIcmpEchoReply;
FSize: DWORD;
MyString:string;
FTimeOut:DWORD;
BufferSize:DWORD;
begin


if ip<>'' then
begin
FIPAddress := inet_addr(PansiChar(ip));
FSize := 40;
BufferSize := SizeOf(TICMPEchoReply) + FSize;
GetMem(pRevData,FSize);
GetMem(pIPE,BufferSize);
FillChar(pIPE^, SizeOf(pIPE^), 0);
pIPE^.Data := pRevData;
MyString := 'Test Net - Sos Admin';
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
info:=ip+ '　' + IntToStr(pIPE^.DataSize) + '　　　' +IntToStr(pIPE^.RTT);
except
info:='Can not find host!';
FreeMem(pRevData);
FreeMem(pIPE);
Exit;
end;
FreeMem(pRevData);
FreeMem(pIPE);
end;


end;

function pingip(ip:string):string;
var
str:string;
ping:Tping;
begin
ping:=Tping.create ;
ping.pinghost(ip,str);
result:=str;
ping.destroy ;
end;


end.

Delphi tarafı

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, ping;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
begin
  label1.caption:=pingip(edit1.Text);
end;

end.