unit UThread;
interface
uses
Classes, Windows, IdIcmpClient;
type
TPingOnceThread =
class(TThread)
private
Ping: TIdIcmpClient;
FIP:
String;
FOnReply: TOnReplyEvent;
procedure SetName;
protected
constructor Create;
destructor Destroy;
property OnReply: TOnReplyEvent
read FOnReply
write FOnReply;
property IP:
String read FIP
write FIP;
procedure Execute;
override;
end;
TPingThread =
class(TThread)
private
FCount: Integer;
FPings:
array [1..100]
of TPingOnceThread;
FResult:
array of TReplyStatus;
FHosts: TStringList;
procedure SetName;
procedure NewReply(Status: TReplyStatus);
procedure Reply(Sender: TComponent;
const ReplyStatus: TReplyStatus);
protected
constructor Create;
destructor Destroy;
function GetNextReply: TReplyStatus;
procedure Execute;
override;
end;
implementation
type
TThreadNameInfo =
record
FType: LongWord;
// muss 0x1000 sein
FName: PChar;
// Zeiger auf Name (in Anwender-Adress-Bereich)
FThreadID: LongWord;
// Thread-ID (-1 ist Caller-Thread)
FFlags: LongWord;
// reserviert für zukünftige Verwendung, muss 0 sein
end;
procedure TPingOnceThread.SetName;
var
ThreadNameInfo: TThreadNameInfo;
begin
ThreadNameInfo.FType := $1000;
ThreadNameInfo.FName := '
TPingOnceThread';
ThreadNameInfo.FThreadID := $FFFFFFFF;
ThreadNameInfo.FFlags := 0;
try
RaiseException( $406D1388, 0, sizeof(ThreadNameInfo)
div sizeof(LongWord), @ThreadNameInfo );
except
end;
end;
constructor TPingOnceThread.Create;
begin
inherited Create(True);
Ping:=TIdIcmpClient.Create(Ping);
end;
destructor TPingOnceThread.Destroy;
begin
Ping.Free;
inherited Destroy;
end;
procedure TPingOnceThread.Execute;
begin
try
//Init
SetName;
Priority:=tpLower;
Ping.OnReply:=FOnReply;
Ping.Host:=FIP;
//Main
try
Ping.Ping;
except
end;
finally
//UnInit
end;
end;
procedure TPingThread.SetName;
var
ThreadNameInfo: TThreadNameInfo;
begin
ThreadNameInfo.FType := $1000;
ThreadNameInfo.FName := '
TPingThread';
ThreadNameInfo.FThreadID := $FFFFFFFF;
ThreadNameInfo.FFlags := 0;
try
RaiseException( $406D1388, 0, sizeof(ThreadNameInfo)
div sizeof(LongWord), @ThreadNameInfo );
except
end;
end;
procedure TPingThread.NewReply(Status: TReplyStatus);
begin
SetLength(FResult,FCount+1);
FResult[FCount]:=Status;
Inc(FCount);
end;
procedure TPingThread.Reply(Sender: TComponent;
const ReplyStatus: TReplyStatus);
begin
NewReply(ReplyStatus);
end;
constructor TPingThread.Create;
begin
inherited Create(True);
FHosts:=TStringList.Create;
FCount:=0;
end;
destructor TPingThread.Destroy;
begin
SetLength(FResult,0);
FHosts.Free;
inherited Destroy;
end;
function TPingThread.GetNextReply: TReplyStatus;
var i:Integer;
begin
Result:=FResult[0];
for i:=0
to FCount-2
do
FResult[i]:=FResult[i+1];
Dec(FCount);
SetLength(FResult,FCount);
end;
procedure TPingThread.Execute;
var Hosts: TStringList;
i, Temp: Integer;
begin
try
//Init
Hosts:=TStringList.Create;
Hosts.AddStrings(FHosts);
//Main
Temp:=Hosts.Count;
for i:=1
to Temp
do
if i>100
then Break
else
begin
FPings[i]:=TPingOnceThread.Create;
FPings[i].FOnReply:=Reply;
FPings[i].IP:=Hosts[0];
Hosts.Delete(0);
FPings[i].Execute;
end;
finally
//UnInit
for i:=1
to 100
do
try
FPings[i].Free;
except
end;
end;
end;
end.