【delphi开源代码栏目提醒】:网学会员为需要delphi开源代码的朋友们搜集整理了fmTraceRouteMainU.pas相关资料,希望对各位网友有所帮助!
{***************************************************************
*
* Project : Traceroute
* Unit Name: fmTraceRouteMainU
* Purpose : Demonstrates a TraceRoute using ICMP
* Version : 1.0
* Date : Wed 25 Apr 2001 - 01:38:35
* Author : <unknown>
* History :
* Tested : Wed 25 Apr 2001 // Allen O'Neill <allen_3710167@qq.com>
*
****************************************************************}
unit fmTraceRouteMainU;
interface
uses
{$IFDEF Linux}
QGraphics, QControls, QForms, QDialogs, QStdCtrls, QComCtrls, QExtCtrls,
QActnList,
{$ELSE}
windows, messages, graphics, controls, forms, dialogs, comctrls, actnlist,
stdctrls, spin, extctrls,
{$ENDIF}
SysUtils, Classes, IdBaseComponent, IdComponent, IdRawBase, IdRawClient, IdIcmpClient,
IdAntiFreezeBase, IdAntiFreeze;
type
TfmTracertMain = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
Panel4: TPanel;
lbLog: TListBox;
Label1: TLabel;
Label2: TLabel;
ActionList1: TActionList;
edTarget: TEdit;
seMaxHops: TSpinEdit;
Button1: TButton;
acGo: TAction;
acResolve: TAction;
acPing: TAction;
acTrace: TAction;
lvTrace: TListView;
IdIcmpClient: TIdIcmpClient;
IdAntiFreeze1: TIdAntiFreeze;
Splitter1: TSplitter;
Button2: TButton;
acStop: TAction;
procedure edTargetChange(Sender: TObject);
procedure acResolveExecute(Sender: TObject);
procedure acGoExecute(Sender: TObject);
procedure acPingExecute(Sender: TObject);
procedure acTraceExecute(Sender: TObject);
procedure lvTraceCompare(Sender: TObject; Item1, Item2: TListItem;
Data: Integer; var Compare: Integer);
procedure acStopExecute(Sender: TObject);
private
{ Private declarations }
bResolved: Boolean;
ResolvedHost: String;
Stopped: Boolean;
function PingHost(Host: string; TTL: Integer): boolean;
function FindItem(TTL: Integer; Add: boolean): TListItem;
public
{ Public declarations }
end;
var
fmTracertMain: TfmTracertMain;
implementation
uses IdStack, IdException;
{$IFDEF MSWINDOWS}{$R *.dfm}{$ELSE}{$R *.xfm}{$ENDIF}
procedure TfmTracertMain.edTargetChange(Sender: TObject);
begin
bResolved := false;
end;
procedure TfmTracertMain.acResolveExecute(Sender: TObject);
begin
bResolved := false;
lbLog.Items.Append(Format('resolving %s',[edTarget.text]));
try
Application.ProcessMessages;
ResolvedHost := gStack.WSGetHostByName(edTarget.text);
bResolved := true;
lbLog.Items.Append(format('%s resolved to %s',[edTarget.text, ResolvedHost]));
except
on e: EIdSocketError do
lbLog.Items.text := lbLog.Items.text + e.message;
end;
end;
procedure TfmTracertMain.acGoExecute(Sender: TObject);
var
saveCursor: TCursor;
begin
saveCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
try
Stopped := false;
acGo.Enabled := false;
acStop.enabled := true;
acResolve.execute;
if bResolved and not stopped then
begin
acPing.execute;
if not stopped then
acTrace.Execute;
end;
acGo.Enabled := true;
acStop.enabled := false;
finally
Screen.Cursor := saveCursor;
end; { try/finally }
end;
function TfmTracertMain.PingHost(Host: string; TTL: Integer): Boolean;
begin
result := false;
IdIcmpClient.Host := Host;
IdIcmpClient.TTL := TTL;
IdIcmpClient.ReceiveTimeout := 5000;
IdIcmpClient.Ping;
case IdIcmpClient.ReplyStatus.ReplyStatusType of
rsEcho:
begin
lbLog.Items.Append(format('response from host %s in %d millisec.',
[
IdIcmpClient.ReplyStatus.FromIpAddress,
IdIcmpClient.ReplyStatus.MsRoundTripTime
]));
result := true;
end;
rsError:
lbLog.Items.Append('Unknown error.');
rsTimeOut:
lbLog.Items.Append('Timed out.');
rsErrorUnreachable:
lbLog.Items.Append(format('Host %s reports destination network unreachable.',
[
IdIcmpClient.ReplyStatus.FromIpAddress
]));
rsErrorTTLExceeded:
lbLog.Items.Append(format('Hope %d %s: TTL expired.',
[
IdIcmpClient.TTL,
IdIcmpClient.ReplyStatus.FromIpAddress
]));
end; // case
end;
procedure TfmTracertMain.acPingExecute(Sender: TObject);
begin
PingHost(ResolvedHost, seMaxHops.value);
Application.ProcessMessages;
end;
function TfmTracertMain.FindItem(TTL: Integer; Add: boolean): TListItem;
var
i: Integer;
begin
result := nil;
// Find the TTL item
if lvTrace.Items.Count < TTL Then
begin
for i := 0 to lvTrace.Items.Count - 1 do
begin
if StrToIntDef(lvTrace.Items[i].Caption, -1) = TTL then
begin
result := lvTrace.Items[i];
Break;
end;
en