[geret]

Уже перебрал несколько вариантов пинга, но всюду ошибки....

При использовании компонента IdIcmpClient, если компьютер в сети выключен - выдет ошибку "Non-echo typr response received" и программа останавливается.

Нашел еще один вариант реализации, но в нем использован компонент ICMP, и выдет ошибку File not found "Icmp.dcu".

Пожалуйста помогите, может кто нибуть хоть что то посоветует.

Вот первый вариант:

Код:

function TForm1.Ping(const AHost : string; const ATimes : integer; 
                          out AvgMS:Double) : Boolean; 
 var 
  R : array of Cardinal; 
  i : integer; 
begin 
  Result := True; 
  AvgMS := 0; 
  if ATimes>0 then 
    with TIdIcmpClient.Create(Self) do 
    try 
        Host := AHost; 
        ReceiveTimeout:=999; //TimeOut du ping 
        SetLength(R,ATimes); 
        {Pinguer le client} 
        for i:=0 to Pred(ATimes) do 
        begin 
            try 
              Ping(); 
              Application.ProcessMessages; //ne bloque pas l'application 
              R[i] := ReplyStatus.MsRoundTripTime; 
            except 
              Result := False; 
              Exit; 
            end; 
          if ReplyStatus.ReplyStatusType<>rsEcho Then result := False; //pas d'йcho, on renvoi false. 
        end; 
        {Faire une moyenne} 
        for i:=Low(R) to High(R) do 
        begin 
          Application.ProcessMessages; 
          AvgMS := AvgMS + R[i]; 
        end; 
        AvgMS := AvgMS / i; 
    finally 
        Free; 
    end; 
end;

Вот второй:

Код:

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
    { Private declarations }
    procedure PingThreadTermPing(Sender: TObject);
    procedure PingThreadTermTrace (Sender: TObject);
  public
    { Public declarations }
  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) {and  (NOT StopFlag)} 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 ;  // ms
                PingTTL := I ;           //  increasing for each hop
                PingLookupReply := true ;
                Resume ;                  // start it now
                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.

Админ: Пользуемся тегами для оформления кода!