Solved

Ping result missing some failures

Posted on 2008-06-18
8
2,843 Views
Last Modified: 2010-07-19
I have written a very small ping wild card application that will search an entire range of ip's, i.e. 192.168.0.x so it will ping from 192.168.0.0 to 192.168.0.254 and tell me whether it is getting a response or not and hen if it does it does a reverse dns lookup.

My problem is that the result is sometimes incorrect for a specific scenario.
I only thought I would expect a pass or fail but it seems that is counts a TTL expired in transit response as a pass, obviously because of the simple method I am using, or a return value I dont know to check.

Below is a copy of the unit of code I am using, and I just call ping( 192.168.0.0)
The result obviously comes from result := ( DW <> 0);
Is there anything else I can check?

As for some more information
A valid ping response looks like this

Pinging 192.168.0.0 with 32 bytes of data:

Reply from 192.168.0.0: bytes=32 time=6ms TTL=255
Reply from 192.168.0.0: bytes=32 time=1ms TTL=255
Reply from 192.168.0.0: bytes=32 time=4ms TTL=255
Reply from 192.168.0.0: bytes=32 time=1ms TTL=255

Ping statistics for 192.168.0.0:
    Packets: Sent = 4, Received = 4, Lost = 0 (0% loss),
Approximate round trip times in milli-seconds:
    Minimum = 1ms, Maximum = 6ms, Average = 3ms

and an invalid one looks might look like this:

Pinging 192.168.0.1 with 32 bytes of data:

Request timed out.
Request timed out.
Request timed out.
Request timed out.

Ping statistics for 192.168.0.1:
    Packets: Sent = 4, Received = 0, Lost = 4 (100% loss),


or look like this

Pinging 192.168.0.2 with 32 bytes of data:

Reply from 192.168.0.2: TTL expired in transit.
Reply from 192.168.0.2: TTL expired in transit.
Reply from 192.168.0.2: TTL expired in transit.
Reply from 192.168.0.2: TTL expired in transit.

Ping statistics for 192.168.0.2:
    Packets: Sent = 4, Received = 4, Lost = 0 (0% loss),
Approximate round trip times in milli-seconds:
    Minimum = 0ms, Maximum = 0ms, Average = 0ms
unit raw_ping;
 
interface
 
uses
   Windows, SysUtils, Classes;
 
type
   TSunB = packed record
      s_b1, s_b2, s_b3, s_b4: byte;
   end;
 
   TSunW = packed record
      s_w1, s_w2: word;
   end;
 
   PIPAddr = ^TIPAddr;
   TIPAddr = record
      case integer of
         0: (S_un_b: TSunB);
         1: (S_un_w: TSunW);
         2: (S_addr: longword);
      end;
 
 IPAddr = TIPAddr;
 
function IcmpCreateFile: THandle; stdcall; external 'icmp.dll';
function IcmpCloseHandle( icmpHandle : THandle) : boolean; stdcall; external 'icmp.dll'
function IcmpSendEcho( IcmpHandle : THandle; DestinationAddress : IPAddr;
                       RequestData : Pointer; RequestSize : Smallint;
                       RequestOptions : pointer;
                       ReplyBuffer : Pointer;
                       ReplySize : DWORD;
                       Timeout : DWORD) : DWORD; stdcall; external 'icmp.dll';
 
 
function Ping(InetAddress : string) : boolean;
 
procedure TranslateStringToTInAddr( AIP: string; var AInAddr);
 
implementation
 
uses
   WinSock;
 
function Fetch( var AInput: string; const ADelim: string = ' ';
                const ADelete: Boolean = true): string;
var
  iPos: Integer;
begin
   if ADelim = #0 then
   begin
      // AnsiPos does not work with #0
      iPos := Pos(ADelim, AInput);
   end else
      begin
         iPos := Pos(ADelim, AInput);
      end;
 
   if iPos = 0 then
   begin
      Result := AInput;
 
      if ADelete then
      begin
         AInput := '';
      end;
   end else
      begin
         result := Copy(AInput, 1, iPos - 1);
         if ADelete then
         begin
            Delete(AInput, 1, iPos + Length(ADelim) - 1);
         end;
      end;
end;
 
procedure TranslateStringToTInAddr(AIP: string; var AInAddr);
var
   phe: PHostEnt;
   pac: PChar;
   GInitData: TWSAData;
begin
   WSAStartup($101, GInitData);
   try
      phe := GetHostByName(PChar(AIP));
      if Assigned(phe) then
      begin
         pac := phe^.h_addr_list^;
         if Assigned(pac) then
         begin
            with TIPAddr(AInAddr).S_un_b do
            begin
               s_b1 := Byte(pac[0]);
               s_b2 := Byte(pac[1]);
               s_b3 := Byte(pac[2]);
               s_b4 := Byte(pac[3]);
            end;
         end else
            begin
               raise Exception.Create('Error getting IP from HostName');
            end;
      end else
         begin
            raise Exception.Create('Error getting HostName');
         end;
   except
      FillChar(AInAddr, SizeOf(AInAddr), #0);
   end;
   WSACleanup;
end;
 
function Ping( InetAddress : string) : boolean;
var
   handle: THandle;
   inAddr: IPAddr;
   DW: DWORD;
   rep: array[ 1..128] of byte;
begin
   result := false;
   handle := IcmpCreateFile;
   if handle = INVALID_HANDLE_VALUE then
      exit;
 
   translateStringToTInAddr( inetAddress, inAddr);
   DW := icmpSendEcho( handle, inAddr, nil, 0, nil, @rep, 128, 0);
   result := ( DW <> 0);
   icmpCloseHandle(Handle);
end;
 
end.

Open in new window

0
Comment
Question by:mikelittlewood
  • 3
  • 2
  • 2
  • +1
8 Comments
 
LVL 37

Expert Comment

by:Geert Gruwez
ID: 21811204
I got this too in a small application to check network failures.
The app pinged several servers.  1 thread for each server (or ip address)
In the end I got this code (extract) using Indy TIdIcmpClient

FIFOPush is just a stacked log routine
procedure TPingThread.Execute;
var Log: string;
  n: integer;
begin
  FStarted := Now;
  FLastSuccess := FStarted;
  FLastFailed := FStarted;
  Log := FHost + '||' + FIP + '||' + IntToStr(FSequence) + '||' + DateTimeToStr(FStarted, FFM);
  if not FSingleTest then
    FIFOPush(idStart, Log);
  repeat
    if FInterVal > 0 then
      sleep(FInterval);
    try
      repeat
        n := FIFOCount;
        (*
        if n >= 100 then
        begin
          //FIFOPush(idRestart, FHOST + '||' + FIP);
          //StopPing(FHost, Self);
          Terminate;
        end;
        *)
        if n >= MaxMessagesQueue then Sleep(2000);
      until (n < MaxMessagesQueue) or Terminated;
      if not Terminated then
      begin
        FPing.Ping(FormatDateTime('dd-mm-yyyy hh:nn:ss.ssss', FSequence);
        Sleep(FTimeOut + 50);
      end;
    except
      on E: Exception do
      begin
        if not FInFail then
        begin
          FLastFailed := Now;
          FInFail := True;
          FIFOPush(idLostConnection, FHost + '||' + FIP + '||' + IntToStr(FSequence) + '||' + DateTimeToStr(FLastFailed, FFM));
          Inc(FTotalFails);
        end else
        begin
          if not FSingleTest then
            FIFOPush(idLostConnectionNext, FHost + '||' + FIP + '||' + IntToStr(FSequence) + '||' + DateTimeToStr(FLastFailed, FFM))
          else
            FIFOPush(idPing, FHost + '||not found');
        end;
      end;
    end;
    FFirst := False;
  until Terminated or FSingleTest;
  if not FSingleTest and not Terminated then
    FIFOPush(idEnd, FHost + '||' + FIP + '||' + IntToStr(FSequence) + '||' + DateTimeToStr(Now, FFM));
end;
 
procedure TPingThread.PingReply(ASender: TComponent; const AReplyStatus: TReplyStatus);
var Temp: string;
begin
  if AReplyStatus.BytesReceived <= 0 then
  begin // Failed
    if not FInFail then
    begin
      FLastFailed := Now;
      FInFail := True;
      if not FSingleTest then
        FIFOPush(idLostConnection, FHost + '||' + AReplyStatus.FromIpAddress + '||' + DateTimeToStr(FLastFailed, FFM) + '||' + IntToStr(AReplyStatus.SequenceId))
      else
        FIFOPush(idPing, FHost + '||not found');
      Inc(FTotalFails);
    end;
  end else
  begin // success
    if AReplyStatus.FromIpAddress = FIP then
    begin
      FLastSuccess := Now;
      if FInFail then
      begin
        FFailedSeconds := SecondsBetween(FLastSuccess, FLastFailed);
        if not FFirst then
        begin
          if not FSingleTest then
            FIFOPush(idReconnected, FHost + '||' + AReplyStatus.FromIpAddress + '||' + DateTimeToStr(FLastSuccess, FFM) + '||' + IntToStr(FFailedSeconds) + '||' + IntToStr(FTotalFails) + IntToStr(AReplyStatus.SequenceId));
        end;
        FInFail := False;
        if FSingleTest then
          FIFOPush(idPing, FHost + '||' + AReplyStatus.FromIpAddress);
      end;
    end
      else FIFOPush(idStrayMessage, FHOST + '||' + AReplyStatus.FromIpAddress);
  end;
  if not FSingleTest then
  begin
    Temp := '';
    case AReplyStatus.ReplyStatusType of
      rsEcho: Temp := 'Echo';
      rsError: Temp := 'Error';
      rsTimeOut: Temp := 'TimeOut';
      rsErrorUnreachable: Temp := 'Unreachable';
      rsErrorTTLExceeded: Temp := 'TTLExceeded';
    end;
    with AReplyStatus do
      FIFOPush(idPingMessage, FHost + '||' + FromIpAddress + '||' + Format('IPAddress: %s; BytesReceived: %d; TimeToLive: %d; RoundTripTime: %d; Status: %s',
        [FromIpAddress, BytesReceived, TimeToLive, MsRoundTripTime, Temp]));
  end;
end;

Open in new window

0
 
LVL 15

Author Comment

by:mikelittlewood
ID: 21811301
I'm wondering if in your code

    case AReplyStatus.ReplyStatusType of
      rsEcho: Temp := 'Echo';
      rsError: Temp := 'Error';
      rsTimeOut: Temp := 'TimeOut';
      rsErrorUnreachable: Temp := 'Unreachable';
      rsErrorTTLExceeded: Temp := 'TTLExceeded';
    end;

is similar to the result from in mine

DW := icmpSendEcho( handle, inAddr, nil, 0, nil, @rep, 128, 0);

Do you have the declaration section for your thread object?
0
 
LVL 15

Author Comment

by:mikelittlewood
ID: 21811668
I've tried a slightly different method using the TIdIcmpClient object from Indy.

 IdIcmpClient1.ReceiveTimeout := 25;
 IdIcmpClient1.Host := '192.168.0.1';
 IdIcmpClient1.Ping;

As soon as I call ping though it throws an error
*************************
Socket Error # 10049
Cannot assign requested address
*************************
All I can assume is that it might be because the port number is set to 0, though if it needs to be something else, I have no idea what value is required.
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 37

Assisted Solution

by:Geert Gruwez
Geert Gruwez earned 25 total points
ID: 21812106
port number 0 is for echo reply
send anything to that port and it should come back the same (echo = echo)

here is the whole unit ... :)
unit PingThread;
 
interface
 
uses
  Classes, IdICMPClient, SysUtils;
 
const
  idLostConnection     = 1;
  idLostConnectionNext = 2;
  idReconnected        = 3;
  idStart              = 4;
  idStop               = 5;
  idEnd                = 6;
  idPing               = 7;
  idPingMessage        = 8;
  idStrayMessage       = 9;
  idRestart            = 10;
 
  MaxMessagesQueue     = 200;
 
type
  TPingThread = class(TThread)
  private
    FHost: string; //host to ping
    FIP: string;
    FInterval: integer;
    FTimeOut: integer;
    FPing: TIdIcmpClient;
    FLastSuccess: TDateTime;
    FLastFailed: TDateTime;
    FFailedSeconds: Int64;
    FStarted: TDateTime;
    FInFail: Boolean;
    FFirst: Boolean;
    FSingleTest: Boolean;
    FTotalFails: Integer;
    FLogPath: string;
    FLastLog: string;
    FFM: TFormatSettings;
    FSequence: word;
    procedure PingReply (ASender: TComponent; const AReplyStatus: TReplyStatus);
  protected
    procedure Execute; override;
  public
    constructor Create(AHost, AIPAddress, ALogPath: string; ASequence: word; ATimeOut: Integer;
      FM: TFormatSettings; ASingleTest: Boolean = False); reintroduce;
    destructor Destroy; override;
 
    property Host: string read FHost;
    property IP: string read FIP;
  end;
 
procedure RunPing(AHost, AIPAddress, ALogPath: string; ATimeOut: Integer; FM: TFormatSettings; ASingleTest: Boolean = False);
procedure StopPing(AHost: string; TheThread: TThread = nil);
procedure HaltPing;
function FindPing(AHost: string; FM: TFormatSettings): string;
 
implementation
 
uses DateUtils, untThreadObjects, Math, Windows;
 
var
  PingList: TThreadList;
  nSequence: word = 0;
 
procedure RunPing(AHost, AIPAddress, ALogPath: string; ATimeOut: Integer; FM: TFormatSettings; ASingleTest: Boolean = False);
var aThread: TPingThread;
  I: Integer;
  Found: Boolean;
begin
  Found := False;
  with PingList.LockList do
  try
    for I := 0 to Count - 1 do
      if SameText(TPingThread(Items[I]).Host, AHost) then
      begin
        Found := True;
        Break;
      end;
  finally
    PingList.UnlockList;
  end;
  if not Found then
  begin
    inc(nSequence);
    with PingList.LockList do
    try
      aThread := TPingThread.Create(AHost, AIPAddress, ALogPath, nSequence, ATimeOut, FM, ASingleTest);
      if not ASingleTest then
        Add(aThread);
      aThread.Resume;
    finally
      PingList.UnlockList;
    end;
  end;
end;
 
procedure StopPing(AHost: string; TheThread: TThread = nil);
var I: Integer;
  aThread: TPingThread;
  aIP: string;
begin
  with PingList.LockList do
  try
    for I := Count - 1 downto 0 do
    begin
      aThread := TPingThread(Items[I]);
      if ((TheThread = nil) and SameText(aThread.Host, aHost)) or
        ((TheThread <> nil) and (aThread = TheThread)) then
      begin
        Delete(I);
        aIP := aThread.IP;
        if TheThread = nil then
          aThread.Terminate;
        FIFOPush(idStop, AHost + '||' + AIP);
      end;
    end;
  finally
    PingList.UnlockList;
  end;
end;
 
procedure HaltPing;
var I: Integer;
  aThread: TPingThread;
begin
  with PingList.LockList do
  try
    for I := Count - 1 downto 0 do
    begin
      aThread := TPingThread(Items[I]);
      Delete(I);
      aThread.Terminate;
    end;
  finally
    PingList.UnlockList;
  end;
end;
 
function FindPing(AHost: string; FM: TFormatSettings): string;
begin
  Result := '';
  RunPing(AHost, '', '', 300, FM, True);
end;
 
{ TPingThread }
 
constructor TPingThread.Create(AHost, AIPAddress, ALogPath: string; ASequence: word; ATimeOut: Integer; FM: TFormatSettings; ASingleTest: Boolean = False);
begin
  inherited Create(True);
  FreeOnTerminate := True;
  FHost := AHost;
  FTimeOut := ATimeOut;
  FInterval := 0;
  FPing := TIdIcmpClient.Create(nil);
  if AIPAddress = '' then
    FPing.Host := AHost
  else
    FPing.Host := AIPAddress;
  FPing.OnReply := PingReply;
  FPing.ReceiveTimeout := fTimeOut;
  FFirst := True;
  FFailedSeconds := 0;
  FSingleTest := ASingleTest;
  FInFail := True;
  FTotalFails := 0;
  FLogPath := ALogPath;
  FLastLog := '';
  FFM := FM;
  FIP := AIPAddress;
  FSequence := aSequence;
end;
 
destructor TPingThread.Destroy;
begin
  FreeAndNil(FPing);
  inherited Destroy;
end;
 
procedure TPingThread.Execute;
var Log: string;
  n: integer;
begin
  FStarted := Now;
  FLastSuccess := FStarted;
  FLastFailed := FStarted;
  Log := FHost + '||' + FIP + '||' + IntToStr(FSequence) + '||' + DateTimeToStr(FStarted, FFM);
  if not FSingleTest then
    FIFOPush(idStart, Log);
  repeat
    if FInterVal > 0 then
      sleep(FInterval);
    try
      repeat
        n := FIFOCount;
        (*
        if n >= 100 then
        begin
          //FIFOPush(idRestart, FHOST + '||' + FIP);
          //StopPing(FHost, Self);
          Terminate;
        end;
        *)
        if n >= MaxMessagesQueue then Sleep(2000);
      until (n < MaxMessagesQueue) or Terminated;
      if not Terminated then
      begin
        FPing.Ping(FormatDateTime('dd-mm-yyyy hh:nn:ss.ssss', FSequence);
        Sleep(FTimeOut + 50);
      end;
    except
      on E: Exception do
      begin
        if not FInFail then
        begin
          FLastFailed := Now;
          FInFail := True;
          FIFOPush(idLostConnection, FHost + '||' + FIP + '||' + IntToStr(FSequence) + '||' + DateTimeToStr(FLastFailed, FFM));
          Inc(FTotalFails);
        end else
        begin
          if not FSingleTest then
            FIFOPush(idLostConnectionNext, FHost + '||' + FIP + '||' + IntToStr(FSequence) + '||' + DateTimeToStr(FLastFailed, FFM))
          else
            FIFOPush(idPing, FHost + '||not found');
        end;
      end;
    end;
    FFirst := False;
  until Terminated or FSingleTest;
  if not FSingleTest and not Terminated then
    FIFOPush(idEnd, FHost + '||' + FIP + '||' + IntToStr(FSequence) + '||' + DateTimeToStr(Now, FFM));
end;
 
procedure TPingThread.PingReply(ASender: TComponent; const AReplyStatus: TReplyStatus);
var Temp: string;
begin
  if AReplyStatus.BytesReceived <= 0 then
  begin // Failed
    if not FInFail then
    begin
      FLastFailed := Now;
      FInFail := True;
      if not FSingleTest then
        FIFOPush(idLostConnection, FHost + '||' + AReplyStatus.FromIpAddress + '||' + DateTimeToStr(FLastFailed, FFM) + '||' + IntToStr(AReplyStatus.SequenceId))
      else
        FIFOPush(idPing, FHost + '||not found');
      Inc(FTotalFails);
    end;
  end else
  begin // success
    if AReplyStatus.FromIpAddress = FIP then
    begin
      FLastSuccess := Now;
      if FInFail then
      begin
        FFailedSeconds := SecondsBetween(FLastSuccess, FLastFailed);
        if not FFirst then
        begin
          if not FSingleTest then
            FIFOPush(idReconnected, FHost + '||' + AReplyStatus.FromIpAddress + '||' + DateTimeToStr(FLastSuccess, FFM) + '||' + IntToStr(FFailedSeconds) + '||' + IntToStr(FTotalFails) + IntToStr(AReplyStatus.SequenceId));
        end;
        FInFail := False;
        if FSingleTest then
          FIFOPush(idPing, FHost + '||' + AReplyStatus.FromIpAddress);
      end;
    end
      else FIFOPush(idStrayMessage, FHOST + '||' + AReplyStatus.FromIpAddress);
  end;
  if not FSingleTest then
  begin
    Temp := '';
    case AReplyStatus.ReplyStatusType of
      rsEcho: Temp := 'Echo';
      rsError: Temp := 'Error';
      rsTimeOut: Temp := 'TimeOut';
      rsErrorUnreachable: Temp := 'Unreachable';
      rsErrorTTLExceeded: Temp := 'TTLExceeded';
    end;
    with AReplyStatus do
      FIFOPush(idPingMessage, FHost + '||' + FromIpAddress + '||' + Format('IPAddress: %s; BytesReceived: %d; TimeToLive: %d; RoundTripTime: %d; Status: %s',
        [FromIpAddress, BytesReceived, TimeToLive, MsRoundTripTime, Temp]));
  end;
end;
 
(*
procedure TPingThread.AddLog(Msg: string; PingOnly: Boolean = False; AddTime: boolean = True);
var
  LogFile: TextFile;
  Temp, aHostFileName: string;
  AHost: string;
begin
  if (FLastLog <> Msg) and (FLogPath <> '') then
  begin
    AHost := FHost + '_ping.log';
    aHostFileName := Format('%s%s',[FLogPath, AHost]);
    AssignFile(LogFile, aHostFileName);
    try
      if FileExists(aHostFileName) then
        Append(LogFile)
      else
        Rewrite(Logfile);
      Temp := '';
      if AddTime then Temp := FormatDateTime('DD/MM/YYYY HH:NN:SS', Now, FFM) + ' - ';
      Writeln(LogFile, Temp + Msg);
    finally
      CloseFile(LogFile);
    end;
  end;
  FLastLog := Msg;
end;
*)
 
initialization
  PingList := TThreadList.Create;
finalization
  FreeAndNil(PingList);
end.

Open in new window

0
 
LVL 37

Expert Comment

by:Geert Gruwez
ID: 21812117
basically you can ping on any port
ping 21 : check if FTP port is open
ping 80 : check if HTTP port is open
0
 
LVL 26

Expert Comment

by:Russell Libby
ID: 21813813
Below is the source for my IcmpUtils unit, and Ping is one of the functions exposed from it. It can take the address in DNS or dotted format, and allows you to pass a timeout value to it. If you pass zero, it will use its default of 5000 ms. As to the response from IcmpEcho, if it succeeded, that does not mean the ping went through. You need to check the Reply's (TICMPEchoReply) status field to ensure its IP_SUCCESS (0), and not one of the following:

  IP_STATUS_BASE          =  11000;
  IP_BUF_TOO_SMALL        =  (IP_STATUS_BASE + 1);
  IP_DEST_NET_UNREACHABLE =  (IP_STATUS_BASE + 2);
  IP_DEST_HOST_UNREACHABLE=  (IP_STATUS_BASE + 3);
  IP_DEST_PROT_UNREACHABLE=  (IP_STATUS_BASE + 4);
  IP_DEST_PORT_UNREACHABLE=  (IP_STATUS_BASE + 5);
  IP_NO_RESOURCES         =  (IP_STATUS_BASE + 6);
  IP_BAD_OPTION           =  (IP_STATUS_BASE + 7);
  IP_HW_ERROR             =  (IP_STATUS_BASE + 8);
  IP_PACKET_TOO_BIG       =  (IP_STATUS_BASE + 9);
  IP_REQ_TIMED_OUT        =  (IP_STATUS_BASE + 10);
  IP_BAD_REQ              =  (IP_STATUS_BASE + 11);
  IP_BAD_ROUTE            =  (IP_STATUS_BASE + 12);
  IP_TTL_EXPIRED_TRANSIT  =  (IP_STATUS_BASE + 13);
  IP_TTL_EXPIRED_REASSEM  =  (IP_STATUS_BASE + 14);
  IP_PARAM_PROBLEM        =  (IP_STATUS_BASE + 15);
  IP_SOURCE_QUENCH        =  (IP_STATUS_BASE + 16);
  IP_OPTION_TOO_BIG       =  (IP_STATUS_BASE + 17);
  IP_BAD_DESTINATION      =  (IP_STATUS_BASE + 18);

Hope this helps,
Russell

----

unit IcmpUtils;
////////////////////////////////////////////////////////////////////////////////
//
//   Unit        :  IcmpUtils
//   Author      :  rllibby
//   Date        :  07.18.2006
//   Description :  Set of ICMP utility routines based off the iphlpapi library
//                  in Windows. Exposes the following:
//
//                  -  Ability to get inbound / outbound ICMP statistics
//                  -  Ping
//                  -  TraceRoute
//
////////////////////////////////////////////////////////////////////////////////
interface

////////////////////////////////////////////////////////////////////////////////
//   Include units
////////////////////////////////////////////////////////////////////////////////
uses
  Windows, SysUtils, Classes, WinSock;

///////////////////////////////////////////////////////////////////////////////
//   ICMP library constants
////////////////////////////////////////////////////////////////////////////////
const
  IPHLPAPI_LIBRARY        =  'iphlpapi.dll';

  /////////////////////////////////////////////////
  // This can optionally be set to use the icmp.dll
  /////////////////////////////////////////////////
  ICMP_LIBRARY            =  IPHLPAPI_LIBRARY;

////////////////////////////////////////////////////////////////////////////////
//   ICMP error constants
////////////////////////////////////////////////////////////////////////////////
const
  IP_SUCCESS              =  ERROR_SUCCESS;
  IP_STATUS_BASE          =  11000;
  IP_BUF_TOO_SMALL        =  (IP_STATUS_BASE + 1);
  IP_DEST_NET_UNREACHABLE =  (IP_STATUS_BASE + 2);
  IP_DEST_HOST_UNREACHABLE=  (IP_STATUS_BASE + 3);
  IP_DEST_PROT_UNREACHABLE=  (IP_STATUS_BASE + 4);
  IP_DEST_PORT_UNREACHABLE=  (IP_STATUS_BASE + 5);
  IP_NO_RESOURCES         =  (IP_STATUS_BASE + 6);
  IP_BAD_OPTION           =  (IP_STATUS_BASE + 7);
  IP_HW_ERROR             =  (IP_STATUS_BASE + 8);
  IP_PACKET_TOO_BIG       =  (IP_STATUS_BASE + 9);
  IP_REQ_TIMED_OUT        =  (IP_STATUS_BASE + 10);
  IP_BAD_REQ              =  (IP_STATUS_BASE + 11);
  IP_BAD_ROUTE            =  (IP_STATUS_BASE + 12);
  IP_TTL_EXPIRED_TRANSIT  =  (IP_STATUS_BASE + 13);
  IP_TTL_EXPIRED_REASSEM  =  (IP_STATUS_BASE + 14);
  IP_PARAM_PROBLEM        =  (IP_STATUS_BASE + 15);
  IP_SOURCE_QUENCH        =  (IP_STATUS_BASE + 16);
  IP_OPTION_TOO_BIG       =  (IP_STATUS_BASE + 17);
  IP_BAD_DESTINATION      =  (IP_STATUS_BASE + 18);

////////////////////////////////////////////////////////////////////////////////
//   ICMP option types
////////////////////////////////////////////////////////////////////////////////
const
  IP_OPT_EOL              =  $00;  // End of list option
  IP_OPT_NOP              =  $01;  // No operation
  IP_OPT_SECURITY         =  $82;  // Security option.
  IP_OPT_LSRR             =  $83;  // Loose source route.
  IP_OPT_SSRR             =  $89;  // Strict source route.
  IP_OPT_RR               =  $07;  // Record route.
  IP_OPT_TS               =  $44;  // Timestamp.
  IP_OPT_SID              =  $88;  // Stream ID (obsolete)

const
  MAX_OPT_SIZE            =  40;

////////////////////////////////////////////////////////////////////////////////
//   ICMP structures
////////////////////////////////////////////////////////////////////////////////
type
  ICMP_OPTION_INFORMATION =  packed record
     Ttl:                 u_char;
     Tos:                 u_char;
     Flags:               u_char;
     OptionsSize:         u_char;
     OptionsData:         Pointer;
  end;
  PICMP_OPTION_INFORMATION=  ^ICMP_OPTION_INFORMATION;
  TICMPOptionInformation  =  ICMP_OPTION_INFORMATION;
  PICMPOptionInformation  =  ^TICMPOptionInformation;

type
  ICMP_ECHO_REPLY         =  packed record
     Address:             u_long;
     Status:              u_long;
     RTTime:              u_long;
     DataSize:            u_short;
     Reserved:            u_short;
     Data:                Pointer;
     Options:             TICMPOptionInformation;
  end;
  PICMPP_ECHO_REPLY       =  ^ICMP_ECHO_REPLY;
  TICMPEchoReply          =  ICMP_ECHO_REPLY;
  PICMPEchoReply          =  ^TICMPEchoReply;

////////////////////////////////////////////////////////////////////////////////
//   ICMP statistics structures
////////////////////////////////////////////////////////////////////////////////
type
  MIBICMPSTATS            =  packed record
     dwMsgs:              DWORD;   // number of messages
     dwErrors:            DWORD;   // number of errors
     dwDestUnreachs:      DWORD;   // destination unreachable messages
     dwTimeExcds:         DWORD;   // time-to-live exceeded messages
     dwParmProbs:         DWORD;   // parameter problem messages
     dwSrcQuenchs:        DWORD;   // source quench messages
     dwRedirects:         DWORD;   // redirection messages
     dwEchos:             DWORD;   // echo requests
     dwEchoReps:          DWORD;   // echo replies
     dwTimestamps:        DWORD;   // time-stamp requests
     dwTimestampReps:     DWORD;   // time-stamp replies
     dwAddrMasks:         DWORD;   // address mask requests
     dwAddrMaskReps:      DWORD;   // address mask replies
  end;
  LPMIBICMPSTATS          =  ^MIBICMPSTATS;
  TMIBIcmpStats           =  MIBICMPSTATS;
  PMIBIcmpStats           =  ^TMIBIcmpStats;

  MIBICMPINFO             =  packed record
     icmpInStats:         MIBICMPSTATS;
     icmpOutStats:        MIBICMPSTATS;
  end;
  LPMIBICMPINFO           =  ^MIBICMPINFO;
  TMIBIcmpInfo            =  MIBICMPINFO;
  PMIBIcmpInfo            =  ^TMIBIcmpInfo;

  MIB_ICMP                =  packed record
     stats:               MIBICMPINFO;
  end;
  LPMIB_ICMP              =  ^MIB_ICMP;
  TMIBIcmp                =  MIB_ICMP;
  PMIBIcmp                =  ^TMIBIcmp;

////////////////////////////////////////////////////////////////////////////////
//   Ping constants
////////////////////////////////////////////////////////////////////////////////
const
  PING_DEF_TIMEOUT        =  5000;

////////////////////////////////////////////////////////////////////////////////
//   ICMP imported functions
////////////////////////////////////////////////////////////////////////////////
function   IcmpCreateFile: THandle; stdcall; external ICMP_LIBRARY;
function   IcmpCloseHandle(icmpHandle: THandle): BOOL; stdcall; external ICMP_LIBRARY;
function   IcmpSendEcho(icmpHandle: THandle; DestinationAddress: TInAddr; RequestData: Pointer; RequestSize: Word; RequestOptions: Pointer; ReplyBuffer: Pointer; ReplySize, Timeout: DWORD): DWORD; stdcall; external ICMP_LIBRARY;
function   GetIcmpStatistics(pStats: LPMIB_ICMP): DWORD; stdcall; external IPHLPAPI_LIBRARY;

////////////////////////////////////////////////////////////////////////////////
//
//   GetLocalIPAddress
//
//      Returns
//
//         Returns the local ip address string in the form of x.x.x.x if
//         successful, an empty string on failure.
//
////////////////////////////////////////////////////////////////////////////////
function   GetLocalIPAddress: String;

////////////////////////////////////////////////////////////////////////////////
//
//   GetTraceRoute
//
//      HostName =  [in] The name of the host system to trace a route to. The
//                  name can be in either DNS format, or dotted name notation.
//
//      List     =  [in] A TStrings or descendant class to fill in with the
//                  result of the trace route to the specified host name. The
//                  string values in the list will contain the IP address in
//                  x.x.x.x notation, and the Objects[x] property for each list
//                  item will be the integer value for round trip time.
//
//      Returns
//
//         If the trace completes, an ERROR_SUCCESS will be returned. Otherwise,
//         the error code causing the failure will be returned.
//
////////////////////////////////////////////////////////////////////////////////
function   GetTraceRoute(HostName: String; List: TStrings): Integer;

////////////////////////////////////////////////////////////////////////////////
//
//   Ping
//
//      HostName =  [in] The name of the host system to get the network address
//                  for. The name can be in either DNS format, or dotted name
//                  notation.
//
//      TimeOut  =  [in/out] On input, determines how long to wait (in ms) for
//                  an echo reply from the host system. If zero is passed, the
//                  default timeout of PING_DEF_TIMEOUT is used. On return, this
//                  will be filled in with the roundtrip time (in ms) to the host.
//
//      Returns
//
//         Returns ERROR_SUCCESS if the host replied to the echo command, else
//         the error code indicating the failure.
//
////////////////////////////////////////////////////////////////////////////////
function   Ping(HostName: String; var Timeout: DWORD): Integer;

////////////////////////////////////////////////////////////////////////////////
//
//   ResolveAddress
//
//      HostName =  [in] The name of the host system to get the network address
//                  for. The name can be in either DNS format, or dotted name
//                  notation.
//
//      Address  =  [out] The binary address of the host system on success.
//
//      Returns
//
//         Returns ERROR_SUCCESS if the host name was converted to a binary ip
//         address, else the error code indicating the failure. On success, the
//         Address param will be filled in with the binary ip address.
//
////////////////////////////////////////////////////////////////////////////////
function   ResolveAddress(HostName: String; out Address: DWORD): Integer;

////////////////////////////////////////////////////////////////////////////////
//
//   TraceRoute
//
//      HostName =  [in] The name of the host system to trace a route to. The
//                  name can be in either DNS format, or dotted name notation.
//
//      CallBack =  [in] The function to callback when an address hop is
//                  resolved. This is not a required param, but if passed in,
//                  returning a False result from the callback will cause the
//                  trace to complete with a result of ERROR_CANCELLED.
//
//      lParam   =  [in] Specifies a 32-bit, application-defined value to be
//                  passed to the callback function.
//
//      Returns
//
//         If the trace completes, an ERROR_SUCCESS will be returned. Otherwise,
//         the error code causing the failure will be returned.
//
////////////////////////////////////////////////////////////////////////////////
type
  TTraceCallback    =  function(HopNumber: Byte; Address: PChar; RoundTripTime: Cardinal; lParam: Integer): Boolean;

function   TraceRoute(HostName: String; CallBack: TTraceCallback; lParam: Integer): Integer;

implementation

////////////////////////////////////////////////////////////////////////////////
//   Protected variables
////////////////////////////////////////////////////////////////////////////////
var
  lpData:           TWSAData;

function ResolveAddress(HostName: String; out Address: DWORD): Integer;
var  lpHost:        PHostEnt;
begin

  // Set default address
  Address:=DWORD(INADDR_NONE);

  // Resource protection
  try
     // Check host name length
     if (Length(HostName) > 0) then
     begin
        // Try converting the hostname
        Address:=inet_addr(PChar(HostName));
        // Check address
        if (DWORD(Address) = DWORD(INADDR_NONE)) then
        begin
           // Attempt to get host by name
           lpHost:=gethostbyname(PChar(HostName));
           // Check host ent structure for valid ip address
           if Assigned(lpHost) and Assigned(lpHost^.h_addr_list^) then
           begin
              // Get the address from the list
              Address:=u_long(PLongInt(lpHost^.h_addr_list^)^);
           end;
        end;
     end;
  finally
     // Check result address
     if (DWORD(Address) = DWORD(INADDR_NONE)) then
        // Invalid host specified
        result:=IP_BAD_DESTINATION
     else
        // Converted correctly
        result:=ERROR_SUCCESS;
  end;

end;

function GetTraceRouteCallback(HopNumber: Byte; Address: PChar; RoundTripTime: Cardinal; lParam: Integer): Boolean;
begin

  // Resource protection
  try
     // Add address and round trip time to list
     TStrings(lParam).AddObject(Address, Pointer(RoundTripTime));
  finally
     // Keep enumerating
     result:=True;
  end;

end;

function GetTraceRoute(HostName: String; List: TStrings): Integer;
begin

  // Check the passed list
  if Assigned(List) then
  begin
     // Lock the list
     List.BeginUpdate;
     // Resource protection
     try
        // Clear the list
        List.Clear;
        // Perform the trace route
        result:=TraceRoute(HostName, GetTraceRouteCallback, Integer(List));
     finally
        // Unlock the list
        List.EndUpdate;
     end;
  end
  else
     // List must be passed
     result:=ERROR_INVALID_PARAMETER;

end;

function Ping(HostName: String; var Timeout: Cardinal): Integer;
var  lpSend:        Array [0..7] of Integer;
     lpReply:       PICMPEchoReply;
     icmpHandle:    THandle;
     dwAddress:     DWORD;
     dwTTL:         DWORD;
begin

  // Convert the address
  result:=ResolveAddress(HostName, dwAddress);

  // Check result
  if (result = ERROR_SUCCESS) then
  begin
     // Open an icmp handle
     icmpHandle:=IcmpCreateFile;
     // Check handle
     if not(icmpHandle = INVALID_HANDLE_VALUE) then
     begin
        // Resource protection
        try
           // Allocate memory for reply
           lpReply:=AllocMem(SizeOf(ICMP_ECHO_REPLY) * 2 + SizeOf(lpSend));
           // Resource protection
           try
              // Get timeout value
              if (Timeout = 0) then
                 // Use default
                 dwTTL:=PING_DEF_TIMEOUT
              else
                 // Use passed value
                 dwTTL:=Timeout;
              // Send echo to the host
              if (IcmpSendEcho(icmpHandle, in_addr(dwAddress), @lpSend, SizeOf(lpSend), nil, lpReply, SizeOf(ICMP_ECHO_REPLY) + SizeOf(lpSend), dwTTL) = 1) then
              begin
                 // Fill in the round trip time
                 Timeout:=lpReply^.RTTime;
                 // Return the status
                 result:=lpReply^.Status;
              end
              else
                 // Request timed out
                 result:=IP_REQ_TIMED_OUT;
           finally
              // Free memory
              FreeMem(lpReply);
           end;
        finally
           // Close handle
           IcmpCloseHandle(icmpHandle);
        end;
     end
     else
        // Failed to open icmp handle, return last error
        result:=GetLastError;
  end;

end;

function TraceRoute(HostName: String; CallBack: TTraceCallback; lParam: Integer): Integer;
var  lpSend:        Array [0..7] of Integer;
     lpAddr:        Array [0..255] of Char;
     lpOpts:        TICMPOptionInformation;
     lpReply:       PICMPEchoReply;
     icmpHandle:    THandle;
     dwAddress:     DWORD;
     dwAttempt:     Integer;
     dwTTL:         Integer;
begin

  // Convert the address
  result:=ResolveAddress(HostName, dwAddress);

  // Check result
  if (result = ERROR_SUCCESS) then
  begin
     // Open an icmp handle
     icmpHandle:=IcmpCreateFile;
     // Check handle
     if not(icmpHandle = INVALID_HANDLE_VALUE) then
     begin
        // Resource protection
        try
           // Clear option structure
           FillChar(lpOpts, SizeOf(lpOpts), 0);
           // Allocate memory for reply
           lpReply:=AllocMem(SizeOf(ICMP_ECHO_REPLY) * 2 + SizeOf(lpSend));
           // Resource protection
           try
              // Set starting TTL count
              dwTTL:=1;
              // Perform the trace route
              while (dwTTL < 256) do
              begin
                 // Set option time to live
                 lpOpts.Ttl:=Char(dwTTL);
                 // Set starting attempt
                 dwAttempt:=0;
                 // Retry up to 3 times
                 while (dwAttempt < 3) do
                 begin
                    // Send 32 bytes of data, break on success
                    if (IcmpSendEcho(icmpHandle, in_addr(dwAddress), @lpSend, SizeOf(lpSend), @lpOpts, lpReply, SizeOf(ICMP_ECHO_REPLY) + SizeOf(lpSend), 1000) = 1) then break;
                    // Increment the attempt
                    Inc(dwAttempt);
                 end;
                 // Check attempt counter
                 if (dwAttempt = 3) then
                 begin
                    // Set result
                    result:=IP_REQ_TIMED_OUT;
                    // Done
                    break;
                 end;
                 // Check callback
                 if Assigned(Callback) then
                 begin
                    // Copy address
                    StrLCopy(@lpAddr, inet_ntoa(in_addr(lpReply^.Address)), Pred(SizeOf(lpAddr)));
                    // If false is returned then we need to stop the trace route
                    if not(Callback(Ord(dwTTL), lpAddr, lpReply^.RTTime, lParam)) then
                    begin
                       // Set result
                       result:=ERROR_CANCELLED;
                       // Done
                       break;
                    end;
                 end;
                 // Check reply status, if IP_SUCCESS then we have reached the desired host
                 if (lpReply^.Status = IP_SUCCESS) then break;
                 // Increment the time to live
                 Inc(dwTTL);
              end;
           finally
              // Free memory
              FreeMem(lpReply);
           end;
        finally
           // Close handle
           IcmpCloseHandle(icmpHandle);
        end;
     end
     else
        // Failed to open icmp handle, return last error
        result:=GetLastError;
  end;

end;

function GetLocalIPAddress: String;
var  lpszName:      Array [0..MAX_PATH] of Char;
     lpHost:        PHostEnt;
begin

  // Get host name
  if (gethostname(@lpszName, SizeOf(lpszName)) = 0) then
  begin
     // Get host ent structure from remote name
     lpHost:=gethostbyname(@lpszName);
     // Check host ent structure for valid ip address
     if Assigned(lpHost) and Assigned(lpHost^.h_addr_list^) then
        // Convert to dot notation string
        result:=inet_ntoa(in_addr(PLongInt(lpHost^.h_addr_list^)^))
     else
        // Failed to resolve name
        SetLength(result, 0);
  end
  else
     // Failed to get name
     SetLength(result, 0);

end;

initialization

  // Initialize winsock
  WSAStartup(MakeWord(1, 1), lpData);

finalization

  // Cleanup winsock
  WSACleanup;

end.

0
 
LVL 26

Accepted Solution

by:
Russell Libby earned 75 total points
ID: 21824883
If your looking for a threaded solution, see the example below.

Russell

-- example --
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  IcmpUtils, StdCtrls;

const
  WM_PINGDONE       =  WM_USER + 10;

type
  TForm1            =  class(TForm)
     Button1:       TButton;
     ListBox1:      TListBox;
     Label1:        TLabel;
     Edit1:         TEdit;
     Label2:        TLabel;
     procedure      Button1Click(Sender: TObject);
     procedure      ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
  private
     // Private declarations
     FCount:        Integer;
  protected
     // Protected declrations
     procedure      WMPingDone(var Message: TMessage); message WM_PINGDONE;
  public
     // Public declarations
  end;

var
  Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.WMPingDone(var Message: TMessage);
var dwIndex:        Integer;
begin

  // Decrement the count
  Dec(FCount);

  // Determine if button can be enabled
  Button1.Enabled:=(FCount = 0);

  // Lookup the item
  dwIndex:=ListBox1.Items.IndexOf(AddressToString(Message.WParam));

  // Check index
  if (dwIndex >= 0) then
  begin
     // Check result
     if (Message.LParam = 0) then
        ListBox1.Items.Objects[dwIndex]:=Pointer(2)
     else
        ListBox1.Items.Objects[dwIndex]:=Pointer(1);
     // Invalidate
     InvalidateRect(ListBox1.Handle, nil, False);
  end;

end;

procedure TForm1.Button1Click(Sender: TObject);
var  i:             Integer;
begin

  // Set count
  FCount:=0;

  // Lock the list
  ListBox1.Items.BeginUpdate;

  // Resource protection
  try
     // Disable the button
     Button1.Enabled:=False;
     // Clear the listbox
     ListBox1.Items.Clear;
     // Ping all hosts in the network range
     for i:=0 to 254 do
     begin
        // Queue the ping
        if (PingAsync(Handle, WM_PINGDONE, Edit1.Text + '.' + IntToStr(i), 0) = ERROR_SUCCESS) then
        begin
           // Increment count
           Inc(FCount);
           // Add to list box
           ListBox1.Items.AddObject(Edit1.Text + '.' + IntToStr(i), nil);
        end;
     end;
  finally
     // Unlock the list
     ListBox1.Items.EndUpdate;
  end;

end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
var  lpItem:        Pointer;
begin

  // With canvas
  with ListBox1.Canvas do
  begin
     // Get the object
     lpItem:=ListBox1.Items.Objects[Index];
     // Check it
     if Assigned(lpItem) then
     begin
        // Determine if the ping was ok
        if (Integer(lpItem) = 1) then
           // Ping failed
           Brush.Color:=clRed
        else
           // Ping success
           Brush.Color:=clGreen;
     end
     else
        // Use window color
        Brush.Color:=clWindow;
     // Clear item rect
     FillRect(Rect);
     // Draw the text
     DrawText(Handle, PChar(ListBox1.Items[Index]), (-1), Rect, DT_CENTER or DT_NOCLIP);
  end;

end;

end.

-- dfm --
object Form1: TForm1
  Left = 364
  Top = 275
  Width = 308
  Height = 499
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = ANSI_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 100
    Top = 16
    Width = 65
    Height = 13
    Alignment = taRightJustify
    Caption = 'Network IP:'
  end
  object Label2: TLabel
    Left = 268
    Top = 16
    Width = 10
    Height = 13
    Caption = '.x'
  end
  object Button1: TButton
    Left = 12
    Top = 12
    Width = 83
    Height = 25
    Caption = 'Ping'
    TabOrder = 0
    OnClick = Button1Click
  end
  object ListBox1: TListBox
    Left = 172
    Top = 40
    Width = 113
    Height = 409
    ItemHeight = 16
    Sorted = True
    Style = lbOwnerDrawFixed
    TabOrder = 1
    OnDrawItem = ListBox1DrawItem
  end
  object Edit1: TEdit
    Left = 172
    Top = 12
    Width = 89
    Height = 21
    TabOrder = 2
    Text = '192.168.1'
  end
end

-- Updated IcmpUtils --
unit IcmpUtils;
////////////////////////////////////////////////////////////////////////////////
//
//   Unit        :  IcmpUtils
//   Author      :  rllibby
//   Date        :  07.18.2006  -  Original
//                  06.19.2008  -  Update to allow for async pinging as well
//                  reverse DNS name lookup, address -> string conversion.
//   Description :  Set of ICMP utility routines based off the iphlpapi library
//                  in Windows. Exposes the following:
//
//                  -  Ability to get inbound / outbound ICMP statistics
//                  -  Ping
//                  -  TraceRoute
//
////////////////////////////////////////////////////////////////////////////////
interface

////////////////////////////////////////////////////////////////////////////////
//   Include units
////////////////////////////////////////////////////////////////////////////////
uses
  Windows, SysUtils, Classes, WinSock;

///////////////////////////////////////////////////////////////////////////////
//   ICMP library constants
////////////////////////////////////////////////////////////////////////////////
const
  IPHLPAPI_LIBRARY        =  'iphlpapi.dll';

  /////////////////////////////////////////////////
  // This can optionally be set to use the icmp.dll
  /////////////////////////////////////////////////
  ICMP_LIBRARY            =  IPHLPAPI_LIBRARY;

////////////////////////////////////////////////////////////////////////////////
//   ICMP error constants
////////////////////////////////////////////////////////////////////////////////
const
  IP_SUCCESS              =  ERROR_SUCCESS;
  IP_STATUS_BASE          =  11000;
  IP_BUF_TOO_SMALL        =  (IP_STATUS_BASE + 1);
  IP_DEST_NET_UNREACHABLE =  (IP_STATUS_BASE + 2);
  IP_DEST_HOST_UNREACHABLE=  (IP_STATUS_BASE + 3);
  IP_DEST_PROT_UNREACHABLE=  (IP_STATUS_BASE + 4);
  IP_DEST_PORT_UNREACHABLE=  (IP_STATUS_BASE + 5);
  IP_NO_RESOURCES         =  (IP_STATUS_BASE + 6);
  IP_BAD_OPTION           =  (IP_STATUS_BASE + 7);
  IP_HW_ERROR             =  (IP_STATUS_BASE + 8);
  IP_PACKET_TOO_BIG       =  (IP_STATUS_BASE + 9);
  IP_REQ_TIMED_OUT        =  (IP_STATUS_BASE + 10);
  IP_BAD_REQ              =  (IP_STATUS_BASE + 11);
  IP_BAD_ROUTE            =  (IP_STATUS_BASE + 12);
  IP_TTL_EXPIRED_TRANSIT  =  (IP_STATUS_BASE + 13);
  IP_TTL_EXPIRED_REASSEM  =  (IP_STATUS_BASE + 14);
  IP_PARAM_PROBLEM        =  (IP_STATUS_BASE + 15);
  IP_SOURCE_QUENCH        =  (IP_STATUS_BASE + 16);
  IP_OPTION_TOO_BIG       =  (IP_STATUS_BASE + 17);
  IP_BAD_DESTINATION      =  (IP_STATUS_BASE + 18);

////////////////////////////////////////////////////////////////////////////////
//   ICMP option types
////////////////////////////////////////////////////////////////////////////////
const
  IP_OPT_EOL              =  $00;  // End of list option
  IP_OPT_NOP              =  $01;  // No operation
  IP_OPT_SECURITY         =  $82;  // Security option.
  IP_OPT_LSRR             =  $83;  // Loose source route.
  IP_OPT_SSRR             =  $89;  // Strict source route.
  IP_OPT_RR               =  $07;  // Record route.
  IP_OPT_TS               =  $44;  // Timestamp.
  IP_OPT_SID              =  $88;  // Stream ID (obsolete)

const
  MAX_OPT_SIZE            =  40;

////////////////////////////////////////////////////////////////////////////////
//   ICMP structures
////////////////////////////////////////////////////////////////////////////////
type
  ICMP_OPTION_INFORMATION =  packed record
     Ttl:                 u_char;
     Tos:                 u_char;
     Flags:               u_char;
     OptionsSize:         u_char;
     OptionsData:         Pointer;
  end;
  PICMP_OPTION_INFORMATION=  ^ICMP_OPTION_INFORMATION;
  TICMPOptionInformation  =  ICMP_OPTION_INFORMATION;
  PICMPOptionInformation  =  ^TICMPOptionInformation;

type
  ICMP_ECHO_REPLY         =  packed record
     Address:             u_long;
     Status:              u_long;
     RTTime:              u_long;
     DataSize:            u_short;
     Reserved:            u_short;
     Data:                Pointer;
     Options:             TICMPOptionInformation;
  end;
  PICMPP_ECHO_REPLY       =  ^ICMP_ECHO_REPLY;
  TICMPEchoReply          =  ICMP_ECHO_REPLY;
  PICMPEchoReply          =  ^TICMPEchoReply;

////////////////////////////////////////////////////////////////////////////////
//   ICMP statistics structures
////////////////////////////////////////////////////////////////////////////////
type
  MIBICMPSTATS            =  packed record
     dwMsgs:              DWORD;   // number of messages
     dwErrors:            DWORD;   // number of errors
     dwDestUnreachs:      DWORD;   // destination unreachable messages
     dwTimeExcds:         DWORD;   // time-to-live exceeded messages
     dwParmProbs:         DWORD;   // parameter problem messages
     dwSrcQuenchs:        DWORD;   // source quench messages
     dwRedirects:         DWORD;   // redirection messages
     dwEchos:             DWORD;   // echo requests
     dwEchoReps:          DWORD;   // echo replies
     dwTimestamps:        DWORD;   // time-stamp requests
     dwTimestampReps:     DWORD;   // time-stamp replies
     dwAddrMasks:         DWORD;   // address mask requests
     dwAddrMaskReps:      DWORD;   // address mask replies
  end;
  LPMIBICMPSTATS          =  ^MIBICMPSTATS;
  TMIBIcmpStats           =  MIBICMPSTATS;
  PMIBIcmpStats           =  ^TMIBIcmpStats;

  MIBICMPINFO             =  packed record
     icmpInStats:         MIBICMPSTATS;
     icmpOutStats:        MIBICMPSTATS;
  end;
  LPMIBICMPINFO           =  ^MIBICMPINFO;
  TMIBIcmpInfo            =  MIBICMPINFO;
  PMIBIcmpInfo            =  ^TMIBIcmpInfo;

  MIB_ICMP                =  packed record
     stats:               MIBICMPINFO;
  end;
  LPMIB_ICMP              =  ^MIB_ICMP;
  TMIBIcmp                =  MIB_ICMP;
  PMIBIcmp                =  ^TMIBIcmp;

////////////////////////////////////////////////////////////////////////////////
//   Threaded ping structure
////////////////////////////////////////////////////////////////////////////////
type
  PPingRequest            =  ^TPingRequest;
  TPingRequest            =  packed record
     hwndNotify:          HWND;
     msgID:               UINT;
     dwAddr:              DWORD;
     dwTimeout:           DWORD;
  end;

////////////////////////////////////////////////////////////////////////////////
//   Ping constants
////////////////////////////////////////////////////////////////////////////////
const
  PING_DEF_TIMEOUT        =  5000;

////////////////////////////////////////////////////////////////////////////////
//   ICMP imported functions
////////////////////////////////////////////////////////////////////////////////
function   IcmpCreateFile: THandle; stdcall; external ICMP_LIBRARY;
function   IcmpCloseHandle(icmpHandle: THandle): BOOL; stdcall; external ICMP_LIBRARY;
function   IcmpSendEcho(icmpHandle: THandle; DestinationAddress: TInAddr; RequestData: Pointer; RequestSize: Word; RequestOptions: Pointer; ReplyBuffer: Pointer; ReplySize, Timeout: DWORD): DWORD; stdcall; external ICMP_LIBRARY;
function   GetIcmpStatistics(pStats: LPMIB_ICMP): DWORD; stdcall; external IPHLPAPI_LIBRARY;

////////////////////////////////////////////////////////////////////////////////
//
//   AddressToStr
//
//      Address  =  [in] The binary address of the host system to return the
//               dotted name for.
//
//      Returns
//
//         Returns the ip address in the dotted name format of x.x.x.x on success,
//         an empty string on failure
//
////////////////////////////////////////////////////////////////////////////////
function   AddressToString(Address: DWORD): String;

////////////////////////////////////////////////////////////////////////////////
//
//   GetLocalIPAddress
//
//      Returns
//
//         Returns the local ip address string in the form of x.x.x.x if
//         successful, an empty string on failure.
//
////////////////////////////////////////////////////////////////////////////////
function   GetLocalIPAddress: String;

////////////////////////////////////////////////////////////////////////////////
//
//   GetTraceRoute
//
//      HostName =  [in] The name of the host system to trace a route to. The
//                  name can be in either DNS format, or dotted name notation.
//
//      List     =  [in] A TStrings or descendant class to fill in with the
//                  result of the trace route to the specified host name. The
//                  string values in the list will contain the IP address in
//                  x.x.x.x notation, and the Objects[x] property for each list
//                  item will be the integer value for round trip time.
//
//      Returns
//
//         If the trace completes, an ERROR_SUCCESS will be returned. Otherwise,
//         the error code causing the failure will be returned.
//
////////////////////////////////////////////////////////////////////////////////
function   GetTraceRoute(HostName: String; List: TStrings): Integer;

////////////////////////////////////////////////////////////////////////////////
//
//   Ping
//
//      HostName =  [in] The name of the host system to get the network address
//                  for. The name can be in either DNS format, or dotted name
//                  notation.
//
//      TimeOut  =  [in/out] On input, determines how long to wait (in ms) for
//                  an echo reply from the host system. If zero is passed, the
//                  default timeout of PING_DEF_TIMEOUT is used. On return, this
//                  will be filled in with the roundtrip time (in ms) to the host.
//
//      Returns
//
//         Returns ERROR_SUCCESS if the host replied to the echo command, else
//         the error code indicating the failure.
//
////////////////////////////////////////////////////////////////////////////////
function   Ping(HostName: String; var Timeout: DWORD): Integer;

////////////////////////////////////////////////////////////////////////////////
//
//   PingAync
//
//      Notify   =  [in] The handle of the window that will be notified when the
//                  ping is complete.
//
//      MsgID    =  [in] The user defined message ID that the ping results will
//                  be messaged back on.
//
//      HostName =  [in] The name of the host system to get the network address
//                  for. The name can be in either DNS format, or dotted name
//                  notation.
//
//      TimeOut  =  [in] Determines how long to wait (in ms) for an echo reply
//                  from the host system. If zero is passed, the default timeout
//                  of PING_DEF_TIMEOUT is used.
//
//      Returns
//
//         Returns ERROR_SUCCESS if the ping request is created (thread). When
//         the ping request comlpetes, a message of MsgID will be sent back to the
//         window specified by Notify. The WParam will be the address that was
//         pinged (name can be reversed using ResolveName) and the LParam will be
//         the results of the ping request.
//
//
////////////////////////////////////////////////////////////////////////////////
function   PingAsync(Notify: HWND; MsgID: UINT; HostName: String; Timeout: DWORD): Integer;

////////////////////////////////////////////////////////////////////////////////
//
//   ResolveAddress
//
//      HostName =  [in] The name of the host system to get the network address
//                  for. The name can be in either DNS format, or dotted name
//                  notation.
//
//      Address  =  [out] The binary address of the host system on success.
//
//      Returns
//
//         Returns ERROR_SUCCESS if the host name was converted to a binary ip
//         address, else the error code indicating the failure. On success, the
//         Address param will be filled in with the binary ip address.
//
////////////////////////////////////////////////////////////////////////////////
function   ResolveAddress(HostName: String; out Address: DWORD): Integer;

////////////////////////////////////////////////////////////////////////////////
//
//   ResolveName
//
//      Address  =  [in] The binary address of the host system to get the name
//                  for.
//
//      Returns
//
//         Returns the (reverse) DNS if the address was looked up and a hostent
//         structure returned, otherwise the dotted name format x.x.x.x for the
//         address is returned.
//
////////////////////////////////////////////////////////////////////////////////
function   ResolveName(Address: PDWORD): String;

////////////////////////////////////////////////////////////////////////////////
//
//   TraceRoute
//
//      HostName =  [in] The name of the host system to trace a route to. The
//                  name can be in either DNS format, or dotted name notation.
//
//      CallBack =  [in] The function to callback when an address hop is
//                  resolved. This is not a required param, but if passed in,
//                  returning a False result from the callback will cause the
//                  trace to complete with a result of ERROR_CANCELLED.
//
//      lParam   =  [in] Specifies a 32-bit, application-defined value to be
//                  passed to the callback function.
//
//      Returns
//
//         If the trace completes, an ERROR_SUCCESS will be returned. Otherwise,
//         the error code causing the failure will be returned.
//
////////////////////////////////////////////////////////////////////////////////
type
  TTraceCallback    =  function(HopNumber: Byte; Address: PChar; RoundTripTime: Cardinal; lParam: Integer): Boolean;

function   TraceRoute(HostName: String; CallBack: TTraceCallback; lParam: Integer): Integer;

implementation

////////////////////////////////////////////////////////////////////////////////
//   Protected variables
////////////////////////////////////////////////////////////////////////////////
var
  lpData:           TWSAData;

function PingThreadFunc(PingRequest: PPingRequest): DWORD; stdcall;
var  lpSend:        Array [0..7] of Integer;
     lpReply:       PICMPEchoReply;
     icmpHandle:    THandle;
     dwTTL:         DWORD;
begin

  // Set default result
  result:=ERROR_SUCCESS;

  // Resource protection
  try
     // Resource protection
     try
        // Resource protection
        try
           // Open an icmp handle
           icmpHandle:=IcmpCreateFile;
           // Check handle
           if not(icmpHandle = INVALID_HANDLE_VALUE) then
           begin
              // Resource protection
              try
                 // Allocate memory for reply
                 lpReply:=AllocMem(SizeOf(ICMP_ECHO_REPLY) * 2 + SizeOf(lpSend));
                 // Resource protection
                 try
                    // Get timeout value
                    if (PingRequest^.dwTimeout = 0) then
                       // Use default
                       dwTTL:=PING_DEF_TIMEOUT
                    else
                       // Use passed value
                       dwTTL:=PingRequest^.dwTimeout;
                    // Send echo to the host
                    if (IcmpSendEcho(icmpHandle, in_addr(PingRequest^.dwAddr), @lpSend, SizeOf(lpSend), nil, lpReply, SizeOf(ICMP_ECHO_REPLY) + SizeOf(lpSend), dwTTL) = 1) then
                       // Return the status
                       result:=lpReply^.Status
                    else
                       // Request timed out
                       result:=IP_REQ_TIMED_OUT;
                 finally
                    // Free memory
                    FreeMem(lpReply);
                 end;
              finally
                 // Close handle
                 IcmpCloseHandle(icmpHandle);
              end;
           end
           else
              // Failed to open icmp handle, return last error
              result:=GetLastError;
        finally
           // Check notification window
           if IsWindow(PingRequest^.hwndNotify) then
           begin
              // Notify window of completed request
              PostMessage(PingRequest^.hwndNotify, PingRequest^.msgID, PingRequest^.dwAddr, result);
           end;
        end;
     finally
        // Free the passed memory
        FreeMem(PingRequest);
     end;
  finally
     // Exit the thread
     ExitThread(result);
  end;

end;

function PingAsync(Notify: HWND; MsgID: UINT; HostName: String; Timeout: DWORD): Integer;
var  lpRequest:     PPingRequest;
     dwAddress:     DWORD;
     dwThread:      DWORD;
begin

  // Set multi threaded state
  IsMultiThread:=True;
 
  // Convert the address
  result:=ResolveAddress(HostName, dwAddress);

  // Check result
  if (result = ERROR_SUCCESS) then
  begin
     // Create structure for the thread request
     lpRequest:=AllocMem(SizeOf(TPingRequest));
     // Fill in the request fields
     lpRequest^.hwndNotify:=Notify;
     lpRequest^.msgID:=MsgID;
     lpRequest^.dwAddr:=dwAddress;
     lpRequest^.dwTimeout:=Timeout;
     // Create the ping request thread
     if (CreateThread(nil, 0, @PingThreadFunc, lpRequest, 0, dwThread) = 0) then
     begin
        // Failed to create listening thread
        result:=GetLastError;
        // Free memory block
        FreeMem(lpRequest);
     end
     else
        // Success
        result:=ERROR_SUCCESS;
  end;

end;

function AddressToString(Address: DWORD): String;
var  lpszAddr:      PChar;
begin

  // Get the ip address in the dotted name format
  lpszAddr:=inet_ntoa(in_addr(Address));

  // Check result
  if Assigned(lpszAddr) then
     // Return string
     SetString(result, lpszAddr, StrLen(lpszAddr))
  else
     // Return empty string
     SetLength(result, 0);

end;

function ResolveName(Address: PDWORD): String;
var  lpHost:        PHostEnt;
begin

  // Get host by address
  lpHost:=gethostbyaddr(Address, SizeOf(DWORD), AF_INET);

  // Check host ent
  if Assigned(lpHost) and Assigned(lpHost^.h_name) then
     // Return the host name
     SetString(result, lpHost^.h_name, StrLen(lpHost^.h_name))
  else
     // Convert address to dotted format
     result:=AddressToString(Address^)

end;

function ResolveAddress(HostName: String; out Address: DWORD): Integer;
var  lpHost:        PHostEnt;
begin

  // Set default address
  Address:=DWORD(INADDR_NONE);

  // Resource protection
  try
     // Check host name length
     if (Length(HostName) > 0) then
     begin
        // Try converting the hostname
        Address:=inet_addr(PChar(HostName));
        // Check address
        if (DWORD(Address) = DWORD(INADDR_NONE)) then
        begin
           // Attempt to get host by name
           lpHost:=gethostbyname(PChar(HostName));
           // Check host ent structure for valid ip address
           if Assigned(lpHost) and Assigned(lpHost^.h_addr_list^) then
           begin
              // Get the address from the list
              Address:=u_long(PLongInt(lpHost^.h_addr_list^)^);
           end;
        end;
     end;
  finally
     // Check result address
     if (DWORD(Address) = DWORD(INADDR_NONE)) then
        // Invalid host specified
        result:=IP_BAD_DESTINATION
     else
        // Converted correctly
        result:=ERROR_SUCCESS;
  end;

end;

function GetTraceRouteCallback(HopNumber: Byte; Address: PChar; RoundTripTime: Cardinal; lParam: Integer): Boolean;
begin

  // Resource protection
  try
     // Add address and round trip time to list
     TStrings(lParam).AddObject(Address, Pointer(RoundTripTime));
  finally
     // Keep enumerating
     result:=True;
  end;

end;

function GetTraceRoute(HostName: String; List: TStrings): Integer;
begin

  // Check the passed list
  if Assigned(List) then
  begin
     // Lock the list
     List.BeginUpdate;
     // Resource protection
     try
        // Clear the list
        List.Clear;
        // Perform the trace route
        result:=TraceRoute(HostName, GetTraceRouteCallback, Integer(List));
     finally
        // Unlock the list
        List.EndUpdate;
     end;
  end
  else
     // List must be passed
     result:=ERROR_INVALID_PARAMETER;

end;

function Ping(HostName: String; var Timeout: Cardinal): Integer;
var  lpSend:        Array [0..7] of Integer;
     lpReply:       PICMPEchoReply;
     icmpHandle:    THandle;
     dwAddress:     DWORD;
     dwTTL:         DWORD;
begin

  // Convert the address
  result:=ResolveAddress(HostName, dwAddress);

  // Check result
  if (result = ERROR_SUCCESS) then
  begin
     // Open an icmp handle
     icmpHandle:=IcmpCreateFile;
     // Check handle
     if not(icmpHandle = INVALID_HANDLE_VALUE) then
     begin
        // Resource protection
        try
           // Allocate memory for reply
           lpReply:=AllocMem(SizeOf(ICMP_ECHO_REPLY) * 2 + SizeOf(lpSend));
           // Resource protection
           try
              // Get timeout value
              if (Timeout = 0) then
                 // Use default
                 dwTTL:=PING_DEF_TIMEOUT
              else
                 // Use passed value
                 dwTTL:=Timeout;
              // Send echo to the host
              if (IcmpSendEcho(icmpHandle, in_addr(dwAddress), @lpSend, SizeOf(lpSend), nil, lpReply, SizeOf(ICMP_ECHO_REPLY) + SizeOf(lpSend), dwTTL) = 1) then
              begin
                 // Fill in the round trip time
                 Timeout:=lpReply^.RTTime;
                 // Return the status
                 result:=lpReply^.Status;
              end
              else
                 // Request timed out
                 result:=IP_REQ_TIMED_OUT;
           finally
              // Free memory
              FreeMem(lpReply);
           end;
        finally
           // Close handle
           IcmpCloseHandle(icmpHandle);
        end;
     end
     else
        // Failed to open icmp handle, return last error
        result:=GetLastError;
  end;

end;

function TraceRoute(HostName: String; CallBack: TTraceCallback; lParam: Integer): Integer;
var  lpSend:        Array [0..7] of Integer;
     lpAddr:        Array [0..255] of Char;
     lpOpts:        TICMPOptionInformation;
     lpReply:       PICMPEchoReply;
     icmpHandle:    THandle;
     dwAddress:     DWORD;
     dwAttempt:     Integer;
     dwTTL:         Integer;
begin

  // Convert the address
  result:=ResolveAddress(HostName, dwAddress);

  // Check result
  if (result = ERROR_SUCCESS) then
  begin
     // Open an icmp handle
     icmpHandle:=IcmpCreateFile;
     // Check handle
     if not(icmpHandle = INVALID_HANDLE_VALUE) then
     begin
        // Resource protection
        try
           // Clear option structure
           FillChar(lpOpts, SizeOf(lpOpts), 0);
           // Allocate memory for reply
           lpReply:=AllocMem(SizeOf(ICMP_ECHO_REPLY) * 2 + SizeOf(lpSend));
           // Resource protection
           try
              // Set starting TTL count
              dwTTL:=1;
              // Perform the trace route
              while (dwTTL < 256) do
              begin
                 // Set option time to live
                 lpOpts.Ttl:=Char(dwTTL);
                 // Set starting attempt
                 dwAttempt:=0;
                 // Retry up to 3 times
                 while (dwAttempt < 3) do
                 begin
                    // Send 32 bytes of data, break on success
                    if (IcmpSendEcho(icmpHandle, in_addr(dwAddress), @lpSend, SizeOf(lpSend), @lpOpts, lpReply, SizeOf(ICMP_ECHO_REPLY) + SizeOf(lpSend), 1000) = 1) then break;
                    // Increment the attempt
                    Inc(dwAttempt);
                 end;
                 // Check attempt counter
                 if (dwAttempt = 3) then
                 begin
                    // Set result
                    result:=IP_REQ_TIMED_OUT;
                    // Done
                    break;
                 end;
                 // Check callback
                 if Assigned(Callback) then
                 begin
                    // Copy address
                    StrLCopy(@lpAddr, inet_ntoa(in_addr(lpReply^.Address)), Pred(SizeOf(lpAddr)));
                    // If false is returned then we need to stop the trace route
                    if not(Callback(Ord(dwTTL), lpAddr, lpReply^.RTTime, lParam)) then
                    begin
                       // Set result
                       result:=ERROR_CANCELLED;
                       // Done
                       break;
                    end;
                 end;
                 // Check reply status, if IP_SUCCESS then we have reached the desired host
                 if (lpReply^.Status = IP_SUCCESS) then break;
                 // Increment the time to live
                 Inc(dwTTL);
              end;
           finally
              // Free memory
              FreeMem(lpReply);
           end;
        finally
           // Close handle
           IcmpCloseHandle(icmpHandle);
        end;
     end
     else
        // Failed to open icmp handle, return last error
        result:=GetLastError;
  end;

end;

function GetLocalIPAddress: String;
var  lpszName:      Array [0..MAX_PATH] of Char;
     lpHost:        PHostEnt;
begin

  // Get host name
  if (gethostname(@lpszName, SizeOf(lpszName)) = 0) then
  begin
     // Get host ent structure from remote name
     lpHost:=gethostbyname(@lpszName);
     // Check host ent structure for valid ip address
     if Assigned(lpHost) and Assigned(lpHost^.h_addr_list^) then
        // Convert to dot notation string
        result:=inet_ntoa(in_addr(PLongInt(lpHost^.h_addr_list^)^))
     else
        // Failed to resolve name
        SetLength(result, 0);
  end
  else
     // Failed to get name
     SetLength(result, 0);

end;

initialization

  // Initialize winsock
  WSAStartup(MakeWord(1, 1), lpData);

finalization

  // Cleanup winsock
  WSACleanup;

end.

0
 

Expert Comment

by:namuh1
ID: 29937165
rllibby, thanks for ICMPUtils.pas - it's saved me several hours of work.  I noticed your website doesn't have your latest version (posted above) hosted there.   It'd be great to see that up to date.

I found it necessary to change typecast inet_addr() in line 201.
     Address := inet_addr(PChar(HostName));
becomes
     Address := DWORD(inet_addr(PChar(HostName)));
in order to avoid range check errors.
0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
Introduction I have seen many questions in this Delphi topic area where queries in threads are needed or suggested. I know bumped into a similar need. This article will address some of the concepts when dealing with a multithreaded delphi database…
Email security requires an ever evolving service that stays up to date with counter-evolving threats. The Email Laundry perform Research and Development to ensure their email security service evolves faster than cyber criminals. We apply our Threat…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

679 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question