Ping Unit modifizieren mit mehr Toleranz

[Piro]

Moin,

ich habe folgende Unit, um meine Server auf Verfügbarkeit zu überprüfen.

Delphi-Quellcode:

unit uPing;
 
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;
 
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, 255, 10000);
  Result := (DW <> 0);
  IcmpCloseHandle(Handle);
end;
 
end.

Ich habe die Timeout Zeit auf 10000 gesetzt aber es kommt immer noch vor, dass einige Server ab und zu nicht erreichbar sind. Fast alle Server befinden sich im LAN und einige im WAN (100Mbit/s Anbindung). Ich habe um die 50 Server, welche ich gleichzeitig anpinge mit hilfe von Threads. Kann es vielleicht daran liegen, dass die Threads gleichzeitig ausgeführt werden und somit die Netzwerkkarte nicht alles mitbekommt?

Hat einer ne Idee, warum es ab und zu vorkommt, dass einige Server nicht erreichbar sind?

Vielen Dank im voraus, Sven