TraceRT Component - Programmers Heaven

Howdy, Stranger!

It looks like you're new here. If you want to get involved, click one of these buttons!

Categories

Welcome to the new platform of Programmer's Heaven! We apologize for the inconvenience caused, if you visited us from a broken link of the previous version. The main reason to move to a new platform is to provide more effective and collaborative experience to you all. Please feel free to experience the new platform and use its exciting features. Contact us for any issue that you need to get clarified. We are more than happy to help you.

TraceRT Component

jfreak53jfreak53 Posts: 3Member
I'm looking for some sort of working TraceRT component or code for Delphi 6. I found one called ICMP something by this lady, andrea something, as you can tell I already deleted it. Wasn't working correctly and giving a lot of errors. I would like to find a component for this, I have searched the web through and through and cannot find anything. If all else fails I will settle for some good code if anyone has code for this.

This is what I'm currently using, I found on internet:

[code]unit TraceRt;
interface

// ===========================================================================
// TRACEROUTE Class
// Mike Heydon Dec 2003
//
// Method
// Trace(IpAddress : string; ResultList : TStrings)
// Returns semi-colon delimited list of ip routes to target
// format .. IP ADDRESS; PING TIME MS; TIME TO LIVE; STATUS
//
// Properties
// IcmpTimeOut : integer (Default = 5000ms)
// IcmpMaxHops : integer (Default = 40)
// ===========================================================================

uses Forms, Windows, Classes, SysUtils, IdIcmpClient;

type
TTraceRoute = class(TObject)
protected
procedure ProcessResponse(Status : TReplyStatus);
procedure AddRoute(AResponseTime : DWORD;
AStatus: TReplyStatus; const AInfo: string );
private
FIcmpTimeOut,
FIcmpMaxHops : integer;
FResults : TStringList;
FICMP : TIdIcmpClient;
FPingStart : cardinal;
FCurrentTTL : integer;
procedure PingTarget;
public
constructor Create;
procedure Trace(const AIpAddress : string; AResultList : TStrings);
property IcmpTimeOut : integer read FIcmpTimeOut write FIcmpTimeOut;
property IcmpMaxHops : integer read FIcmpMaxHops write FIcmpMaxHops;
end;

// ---------------------------------------------------------------------------
implementation

// ========================================
// Create the class and set defaults
// ========================================

constructor TTraceRoute.Create;
begin
IcmpTimeOut := 5000;
IcmpMaxHops := 40;
end;


// =============================================
// Use Indy component to ping hops to target
// =============================================

procedure TTraceRoute.PingTarget;
var wOldMode : DWORD;
begin
Application.ProcessMessages;
inc(FCurrentTTL);

if FCurrentTTL < FIcmpMaxHops then begin
FICMP.TTL := FCurrentTTL;
FICMP.ReceiveTimeout := FIcmpTimeOut;
FPingStart := GetTickCount;
wOldMode := SetErrorMode(SEM_FAILCRITICALERRORS);

try
FICMP.Ping;
ProcessResponse(FICMP.ReplyStatus);
except
FResults.Add('0.0.0.0;0;0;ERROR');
end;

SetErrorMode(wOldMode);
end
else
FResults.Add('0.0.0.0;0;0;MAX HOPS EXCEEDED');
end;


// ============================================================
// Add the ping reply status data to the returned stringlist
// ============================================================

procedure TTraceRoute.AddRoute(AResponseTime : DWORD;
AStatus: TReplyStatus;
const AInfo: string );
begin
FResults.Add(AStatus.FromIPAddress + ';' +
IntToStr(GetTickCount - AResponseTime) + ';' +
IntToStr(AStatus.TimeToLive) + ';' + AInfo);
end;


// ============================================================
// Process the ping reply status record and add to stringlist
// ============================================================

procedure TTraceRoute.ProcessResponse(Status : TReplyStatus);
begin
case Status.ReplyStatusType of
// Last Leg - Terminate Trace
rsECHO : AddRoute(FPingStart,Status,'OK');

// More Hops to go - Continue Pinging
rsErrorTTLExceeded : begin
AddRoute(FPingStart,Status,'OK');
PingTarget;
end;

// Error conditions - Terminate Trace
rsTimeOut : AddRoute(FPingStart,Status,'TIMEOUT');
rsErrorUnreachable : AddRoute(FPingStart,Status,'UNREACHABLE');
rsError : AddRoute(FPingStart,Status,'ERROR');
end;
end;

// ======================================================
// Trace route to target IP address
// Results returned in semi-colon delimited stringlist
// IP; TIME MS; TIME TO LIVE; STATUS
// ======================================================

procedure TTraceRoute.Trace(const AIpAddress : string;
AResultList : TStrings);
begin
FICMP := TIdIcmpClient.Create(nil);
FICMP.Host := AIpAddress;
FResults := TStringList(AResultList);
FResults.Clear;
FCurrentTTL := 0;
PingTarget;
FICMP.Free;
end;

{eof}
end.[/code]

This work fine, no problem. The only thing is that when I run it with a web address or even a web IP that is not local it will not resolve or go past my local router, it times out and stops. Any ideas?

I will settle for this script if I can get it working for sites as well as local.
Sign In or Register to comment.