unit uPingThread;

interface

uses
  windows,
  winsock,
  Sysutils,
  Classes;

const
  PACKET_SIZE = 32;
  ICMP_ECHO_REQUEST = 8;

type
  PICMP = ^TICMP;
  TICMP = packed record
    Typ : Byte;
    Code : Byte;
    CheckSum : Word;
    ID : Word;
    Seq_Num : Word;
    Data : array[1..PACKET_SIZE] of Byte;
  end;

  TPingCallBack = function(ErrorCode: integer; nMsec: integer;
    const AMsg: string; AICMP: TICMP): Boolean of object;

  TPingThread = class(TThread)
  private
    FPingCallBack: TPingCallBack;
    FIPAddr: string;
    FICMP: TICMP;
    procedure Ping;
  public
    procedure Execute; override;
    constructor Create(const AIPAddr: string; APingCallBack: TPingCallBack);
    destructor Destroy; override;
  end;

implementation

var
  _WsadData : TWsaData;
  _SeqNum : Word = 0;
  _SeqID : Word = Word(-1);
  _SocketLock : TRTLCriticalSection;

procedure TPingThread.Ping;
var
  Addr: TSockAddr;
  Sock: TSocket;
  ICMP: TICMP;
  ICMPret: PICMP;
  i: Integer;
  Start, Ende: Integer;
  Read: TFDSet;
  TimeOut: TTimeVal;
  buf: array [0..1023] of Byte;
  IPHeaderLen, IPLen: Integer;
  Checksum: Word;
  CheckSumTemp: Integer;
  pw: PWord;
  nMsec: integer;
begin
  nMsec := Integer(-1);
  try
    nMsec := Integer(-1);
    ZeroMemory(@FICMP, SizeOf(TICMP));

    EnterCriticalSection(_SocketLock);
    try
      if _SeqNum = word(-1) then _SeqNum := 0;
      Inc(_SeqNum);

      if _SeqID = 0 then _SeqNum := word(-1);
      Dec(_SeqID);
    finally
      LeaveCriticalSection(_SocketLock);
    end;

    Sock := Socket(AF_INET, SOCK_RAW, IPPROTO_ICMP);
    if Sock = invalid_Socket then begin
      FPingCallBack(WSAGetLastError, -1, SysErrorMessage(WSAGetLastError),
        FICMP);
      Exit;
    end;
    try
      EnterCriticalSection(_SocketLock);
      try
        ICMP.Typ := ICMP_ECHO_REQUEST;
        ICMP.Code := 0;
        ICMP.CheckSum := 0;
        ICMP.ID := _SeqID;
        ICMP.Seq_Num := swap(_SeqNum);

        FillChar(ICMP.Data, Length(ICMP.Data), 9);

        pw := @ICMP;
        CheckSum := 0;
        for i := 1 to sizeof(ICMP) div 2 do begin
          CheckSumTemp := CheckSum + not(swap(pw^));
          CheckSum := CheckSumtemp and $FFFF;
          inc(CheckSum,(CheckSumTemp and $10000) shr 16);
          inc(pw);
        end;
        if sizeof(ICMP) mod 2 = 1 then begin
          CheckSumTemp := CheckSum + not(swap(word(ICMP.data[high(ICMP.data)])));
          CheckSum := CheckSumtemp and $FFFF;
          inc(CheckSum, (CheckSumTemp and $10000) shr 16);
        end;
        ICMP.CheckSum:=swap(CheckSum);

        addr.sin_family := AF_INET;
        addr.sin_port := 0;
        addr.sin_addr.S_addr := Inet_Addr(PAnsiChar(FIPAddr));
      finally
        LeaveCriticalSection(_SocketLock);
      end;

      if sendto(sock, ICMP, sizeof(ICMP), 0, addr, sizeof(Addr)) =
        Socket_Error then
      begin
        FPingCallBack(WSAGetLastError, -1, SysErrorMessage(WSAGetLastError),
          FICMP);
        Exit;
      end;
      start := gettickcount;
      FD_ZERO(Read);
      FD_Set(sock,Read);
      TimeOut.tv_sec := 2;
      TimeOut.tv_usec := 0;
      if Select(0, @Read, nil, nil, @TimeOut) > 0 then begin
        IPLen := recv(sock, buf, length(buf), 0);
        Ende := gettickcount;

        if IPLen = Socket_Error then
          raise Exception.Create(
            'Fehler bei recv' + #13#10 +
              SysErrorMessage(WSAGetLastError));

        if ((buf[0] and $F0) shr 4 = 4) then begin
          IPHeaderlen := (buf[0] and $0F) * 4;

          if IPHEaderlen + sizeof(ICMP) < IPLen then
            raise Exception.Create('Antwortpaket zu kurz');

          ICMPret := @buf[IPHeaderlen];

          move(ICMPret^, FICMP, SizeOf(TICMP));
          case ICMPret^.Typ of
            0 : begin
                  nMsec := Ende - Start;
                  FPingCallBack(WSAGetLastError, nMsec,
                    format(FIPAddr + ' Antwort in %d ms erhalten', [nMsec]),
                      FICMP);
            end;
            3 : FPingCallBack(WSAGetLastError, nMsec,
                  FIPAddr + ' Ziel nicht erreichbar Error ' +
                    IntToStr(ICMPret^.Code), FICMP);

            11: FPingCallBack(WSAGetLastError, nMsec,
                  FIPAddr + ' Zeitlimit (TTL) überschritten' +
                    IntToStr(ICMPret^.Code), FICMP);

            else
              FPingCallBack(WSAGetLastError, nMsec,
                  format(FIPAddr + ' Unbekannte Antwort: Typ %d',
                    [ICMPret^.Code]), FICMP);
          end;
        end else
          FPingCallBack(WSAGetLastError, nMsec,FIPAddr +
            ' Kann IPv6 nicht lesen.', FICMP);
      end else
        FPingCallBack(WSAGetLastError, nMsec, FIPAddr + ' TimeOut',FICMP);
    finally
      closesocket(sock);
    end;
  except
    on e: exception do begin
      FPingCallBack(WSAGetLastError, nMsec, e.Message, FICMP);
    end;
  end;
end;

{ TPingThread }

constructor TPingThread.Create(const AIPAddr: string;
  APingCallBack: TPingCallBack);
begin
  inherited create(true);
  FreeOnTerminate := true;
  FPingCallBack := APingCallBack;
  if @FPingCallBack = nil then
    Raise Exception.Create('TPingCallBack not assigned!');
  FIPAddr := AIPAddr;
  ZeroMemory(@FICMP, SizeOf(TICMP));
  Resume;
end;

destructor TPingThread.Destroy;
begin
  inherited;
end;

procedure TPingThread.Execute;
begin
  Ping;
  Sleep(30);
  Ping;
  Sleep(30);
  Ping;
  Sleep(30);
end;

initialization
  if (WSAStartup($0020, _WsadData) <> S_OK) then
    raise Exception.Create('WSAStartup: ' + IntToStr(WSAGetLastError));
  InitializeCriticalSection(_SocketLock);
finalization
  DeleteCriticalSection(_SocketLock);
  if (WSACleanup <> S_OK) then
    raise Exception.Create('WSACleanup: ' + IntToStr(WSAGetLastError));
end.

unit Unit1;

interface

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


type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    function PingCallBack(ErrorCode: integer; nMsec: integer;
      const AMsg: string; AICMP: TICMP): boolean;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}


function TForm1.PingCallBack(ErrorCode: integer; nMsec: integer;
    const AMsg: string; AICMP: TICMP): boolean;
begin
  memo1.Lines.Add(AMsg);
  result := true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  TPingThread.Create('10.1.10.8', PingCallBack);
  TPingThread.Create('10.7.1.11', PingCallBack);
  TPingThread.Create('10.3.1.9', PingCallBack);
  TPingThread.Create('10.5.10.91', PingCallBack);
end;

end.