unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, PingThrd;
type
TForm1 = class(TForm)
doPing1: TButton;
doExit: TButton;
HostNames: TMemo;
LogWindow: TMemo;
doPingAll: TButton;
doTrace: TButton;
procedure doExitClick(Sender: TObject);
procedure doPingClick(Sender: TObject);
procedure doTraceClick(Sender: TObject);
private
procedure PingThreadTermPing(Sender: TObject);
procedure PingThreadTermTrace (Sender: TObject);
public
end;
const
TraceMax = 32;
MaxErrors = 8;
var
Form1: TForm1;
TraceAddr: array [1..TraceMax] of string;
Trace1st: integer;
TraceErrs: integer;
TraceIPAddr: string;
TraceDoneFlag: boolean;
RevLook1st: integer;
StopFlag: boolean;
PendingPings: integer;
implementation
{$R *.DFM}
procedure TForm1.doExitClick(Sender: TObject);
begin
Close;
end;
procedure TForm1.PingThreadTermPing (Sender: TObject);
const
response1 = 'Thread %d for %s, %s' ;
response2 = 'Thread %d for %s, received %d bytes from %s in %dms' ;
var
info: string;
begin
if Application.Terminated then exit ;
begin
with Sender as TPingThread do
if ReplyTotal <> 0 then
LogWindow.Lines.Add (Format (response2, [PingId, PingHostName,
ReplyDataSize, ReplyIPAddr, ReplyRTT]))
else
LogWindow.Lines.Add (Format (response1, [PingId,
PingHostName, ErrString])) ;
end;
end;
procedure TForm1.doPingClick(Sender: TObject);
var
I, T: integer ;
begin
T := HostNames.Lines.Count ;
if T = 0 then exit ;
if Sender = doPing1 then T := 1 ;
LogWindow.Lines.Add ('') ;
for I := 0 to Pred (T) do
begin
if HostNames.Lines [i] <> '' then
begin
with TPingThread.Create (True) do
begin
PingAddThread (ThreadId) ;
FreeOnTerminate := True;
PingId := succ (I) ;
OnTerminate := PingThreadTermPing ; response
PingHostName := HostNames.Lines [i] ; address to ping
PingTimeout := 4000 ;
PingTTL := 32 ;
PingLookupReply := false ;
Resume ;
end ;
end;
end ;
end;
procedure TForm1.PingThreadTermTrace (Sender: TObject);
const
response1 = 'Ping of %d bytes took %d msecs' ;
response2 = '%2d %4d %-16s %s' ;
var
logline, addrstr: string ;
I: integer ;
begin
if PendingPings > 0 then dec (PendingPings) ;
if stopflag then exit ;
if Application.Terminated then exit ;
with Sender as TPingThread do
begin
if ErrCode <> 0 then
begin
if PingId = -1 then
begin
TraceIPAddr := DnsHostIP ;
LogWindow.Lines.Add ('Can Not Ping Host (' +
DnsHostIP + ') : ' + ErrString) ;
exit ;
end ;
if TraceDoneFlag then exit ;
logline := Format (response2, [PingId, 0, ' ', 'Request timed out']) ;
inc (TraceErrs) ;
if TraceErrs >= MaxErrors then
begin
LogWindow.Lines.Add ('Stopped Due to Excessive Errors') ;
TraceDoneFlag := true ;
end ;
end
else
begin
if PingId = -1 then
begin
TraceIPAddr := DnsHostIP ;
LogWindow.Lines.Add (Format (response1,
[ReplyDataSize, ReplyRTT])) ;
exit ;
end ;
addrstr := ReplyIPAddr ;
if addrstr <> '' then
begin
if TraceIPAddr = addrstr then TraceDoneFlag := true ;
for I := 1 to TraceMax do
begin
if TraceAddr [i] = addrstr then exit ;
end ;
end ;
TraceAddr [PingId] := addrstr ;
logline := Format (response2, [PingId, ReplyRTT, addrstr, ReplyHostName]) ;
end ;
while LogWindow.Lines.Count <= (Trace1st + PingId) do
LogWindow.Lines.Add ('') ;
LogWindow.Lines [Trace1st + PingId] := TrimRight (logline) ;
PingRemoveThread (PingThreadNum) ;
end ;
end ;
procedure TForm1.doTraceClick(Sender: TObject);
var
newaddr, firstaddr, info, logline: string;
I: integer;
EndTimer, timeout: longword;
threadnums: array of integer;
begin
if HostNames.Lines.Count = 0 then exit ;
try
try
StopFlag := false ;
TraceDoneFlag := false ;
if HostNames.Lines [0] = '' then exit ;
doTrace.Enabled := false ;
doExit.Enabled := false ;
newaddr := LongAddr2Dotted (HostNames.Lines [0]) ;
LogWindow.Lines.Add ('') ;
LogWindow.Lines.Add ('Trace Route to: ' + HostNames.Lines [0]) ;
Trace1st := LogWindow.Lines.Count - 1 ;
TraceErrs := 0 ;
timeout := 4000 ;
PendingPings := 0 ;
SetLength (threadnums, TraceMax) ;
for I := 1 to TraceMax do TraceAddr [i] := '' ;
TraceIPAddr := '' ;
with TPingThread.Create (True) do
begin
PingThreadNum := PingAddThread (ThreadId) ;
threadnums [0] := PingThreadNum ;
FreeOnTerminate := True;
PingId := -1 ;
OnTerminate := PingThreadTermTrace ;
PingHostName := newaddr ;
PingTimeout := timeout ;
PingTTL := TraceMax ;
PingLookupReply := false ;
Resume ;
inc (PendingPings) ;
end;
EndTimer := GetTickCount + timeout + 1000 ;
while (PendingPings > 0) do
begin
Application.ProcessMessages ;
if GetTickCount > EndTimer then break ;
end ;
if TraceIPAddr = '' then exit ;
Trace1st := LogWindow.Lines.Count - 1 ;
for I := 1 to TraceMax do
begin
with TPingThread.Create (True) do
begin
PingThreadNum := PingAddThread (ThreadId) ;
threadnums [pred (I)] := PingThreadNum ;
FreeOnTerminate := True;
PingId := I ;
OnTerminate := PingThreadTermTrace ;
PingHostName := TraceIPAddr ;
PingTimeout := timeout ;
PingTTL := I ;
PingLookupReply := true ;
Resume ;
inc (PendingPings) ;
EndTimer := GetTickCount + 500 ;
while (PendingPings > 0) do
begin
Application.ProcessMessages;
if (GetTickCount > EndTimer) and (PendingPings < 6) then break;
end ;
if StopFlag then break;
if TraceDoneFlag then break;
end ;
end ;
EndTimer := GetTickCount + 30000 ;
while (PendingPings > 0) and (NOT StopFlag) do
begin
Application.ProcessMessages ;
if GetTickCount > EndTimer then break ;
end ;
if (PendingPings > 0) then
begin
for I := 1 to TraceMax do
PingTerm1Thread (threadnums [pred (I)]);
end ;
if StopFlag then LogWindow.Lines.Add ('Stopped by User');
LogWindow.Lines.Add ('Trace Route Completed');
beep ;
except
LogWindow.Lines.Add ('Error Sending Pings');
beep ;
end ;
finally
doTrace.Enabled := true;
doExit.Enabled := true;
end ;
end;
end.
31.03.2011, 14:30
Помогите с программой PING
Древовидный вид