如何实现PING功能测试某一IP地址通迅状况?

unit icmp;

interface

{$IFDEF VER80}
// This source file is *NOT* compatible with Delphi 1 because it uses
// Win 32 features.
{$ENDIF}

uses
  Windows, SysUtils, Classes, WinSock;

const
  IcmpVersion = 102;
  IcmpDLL = 'icmp.dll';
  // IP status codes returned to transports and user IOCTLs.
  IP_SUCCESS = 0;
  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);
  // status codes passed up on status indications.
  IP_ADDR_DELETED = (IP_STATUS_BASE + 19);
  IP_SPEC_MTU_CHANGE = (IP_STATUS_BASE + 20);
  IP_MTU_CHANGE = (IP_STATUS_BASE + 21);
  IP_GENERAL_FAILURE = (IP_STATUS_BASE + 50);
  MAX_IP_STATUS = IP_GENERAL_FAILURE;
  IP_PENDING = (IP_STATUS_BASE + 255);
  // IP header flags
  IP_FLAG_DF = $02; // Don't fragment this packet.
  // IP Option Types
  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)
  MAX_OPT_SIZE = $40;

type
  // IP types
  TIPAddr = DWORD; // An IP address.
  TIPMask = DWORD; // An IP subnet mask.
  TIPStatus = DWORD; // Status code returned from IP APIs.
  PIPOptionInformation = ^TIPOptionInformation;

  TIPOptionInformation = packed record
    TTL: Byte; // Time To Live (used for traceroute)
    TOS: Byte; // Type Of Service (usually 0)
    Flags: Byte; // IP header flags (usually 0)
    OptionsSize: Byte; // Size of options data (usually 0, max 40)
    OptionsData: PChar; // Options data buffer
  end;

  PIcmpEchoReply = ^TIcmpEchoReply;

  TIcmpEchoReply = packed record
    Address: TIPAddr; // Replying address
    Status: DWORD; // IP status value
    RTT: DWORD; // Round Trip Time in milliseconds
    DataSize: Word; // Reply data size
    Reserved: Word; // Reserved
    Data: Pointer; // Pointer to reply data buffer
    Options: TIPOptionInformation; // Reply options
  end;

  // IcmpCreateFile:
  // Opens a handle on which ICMP Echo Requests can be issued.
  // Arguments:
  // None.
  // Return Value:
  // An open file handle or INVALID_HANDLE_VALUE. Extended error information
  // is available by calling GetLastError().
  TIcmpCreateFile = function: THandle; stdcall;
  // IcmpCloseHandle:
  // Closes a handle opened by ICMPOpenFile.
  // Arguments:
  // IcmpHandle  - The handle to close.
  // Return Value:
  // TRUE if the handle was closed successfully, otherwise FALSE. Extended
  // error information is available by calling GetLastError().
  TIcmpCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall;
  // IcmpSendEcho:
  // Sends an ICMP Echo request and returns one or more replies. The
  // call returns when the timeout has expired or the reply buffer
  // is filled.
  // Arguments:
  // IcmpHandle         - An open handle returned by ICMPCreateFile.
  // DestinationAddress - The destination of the echo request.
  // RequestData        - A buffer containing the data to send in the
  // request.
  // RequestSize        - The number of bytes in the request data buffer.
  // RequestOptions     - Pointer to the IP header options for the request.
  // May be NULL.
  // ReplyBuffer        - A buffer to hold any replies to the request.
  // On return, the buffer will contain an array of
  // ICMP_ECHO_REPLY structures followed by options
  // and data. The buffer should be large enough to
  // hold at least one ICMP_ECHO_REPLY structure
  // and 8 bytes of data - this is the size of
  // an ICMP error message.
  // ReplySize          - The size in bytes of the reply buffer.
  // Timeout            - The time in milliseconds to wait for replies.
  // Return Value:
  // Returns the number of replies received and stored in ReplyBuffer. If
  // the return value is zero, extended error information is available
  // via GetLastError().
  TIcmpSendEcho = function(IcmpHandle: THandle; DestinationAddress: TIPAddr;
    RequestData: Pointer; RequestSize: Word;
    RequestOptions: PIPOptionInformation; ReplyBuffer: Pointer;
    ReplySize: DWORD; Timeout: DWORD): DWORD; stdcall;
  // Event handler type declaration for TICMP.OnDisplay event.
  TICMPDisplay = procedure(Sender: TObject; Msg: String) of object;
  TICMPReply = procedure(Sender: TObject; Error: Integer) of object;

  // The object wich encapsulate the ICMP.DLL
  TICMP = class(TObject)
  private
    hICMPdll: HModule; // Handle for ICMP.DLL
    IcmpCreateFile: TIcmpCreateFile;
    IcmpCloseHandle: TIcmpCloseHandle;
    IcmpSendEcho: TIcmpSendEcho;
    hICMP: THandle; // Handle for the ICMP Calls
    FReply: TIcmpEchoReply; // ICMP Echo reply buffer
    FAddress: String; // Address given
    FHostName: String; // Dotted IP of host (output)
    FHostIP: String; // Name of host      (Output)
    FIPAddress: TIPAddr; // Address of host to contact
    FSize: Integer; // Packet size (default to 56)
    FTimeOut: Integer; // Timeout (default to 4000mS)
    FTTL: Integer; // Time To Live (for send)
    FOnDisplay: TICMPDisplay; // Event handler to display
    FOnEchoRequest: TNotifyEvent;
    FOnEchoReply: TICMPReply;
    FLastError: DWORD; // After sending ICMP packet
    FAddrResolved: Boolean;
    procedure ResolveAddr;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    function Ping: Integer;
    procedure SetAddress(Value: String);
    function GetErrorString: String;
    property Address: String read FAddress write SetAddress;
    property Size: Integer read FSize write FSize;
    property Timeout: Integer read FTimeOut write FTimeOut;
    property Reply: TIcmpEchoReply read FReply;
    property TTL: Integer read FTTL write FTTL;
    property ErrorCode: Integer read FLastError;
    property ErrorString: String read GetErrorString;
    property HostName: String read FHostName;
    property HostIP: String read FHostIP;
    property OnDisplay: TICMPDisplay read FOnDisplay write FOnDisplay;
    property OnEchoRequest: TNotifyEvent read FOnEchoRequest
      write FOnEchoRequest;
    property OnEchoReply: TICMPReply read FOnEchoReply write FOnEchoReply;
  end;

  TICMPException = class(Exception);

implementation

{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
constructor TICMP.Create;
var
  WSAData: TWSAData;
begin
  hICMP := INVALID_HANDLE_VALUE;
  FSize := 56;
  FTTL := 64;
  FTimeOut := 4000;
  // initialise winsock
  if WSAStartup($101, WSAData) <> 0 then
    raise TICMPException.Create('Error initialising Winsock');
  // register the icmp.dll stuff
  hICMPdll := LoadLibrary(IcmpDLL);
  if hICMPdll = 0 then
    raise TICMPException.Create('Unable to register ' + IcmpDLL);
  @IcmpCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');
  @IcmpCloseHandle := GetProcAddress(hICMPdll, 'IcmpCloseHandle');
  @IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');
  if (@IcmpCreateFile = Nil) or (@IcmpCloseHandle = Nil) or (@IcmpSendEcho = Nil)
  then
    raise TICMPException.Create('Error loading dll functions');
  hICMP := IcmpCreateFile;
  if hICMP = INVALID_HANDLE_VALUE then
    raise TICMPException.Create('Unable to get ping handle');
end;

{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
destructor TICMP.Destroy;
begin
  if hICMP <> INVALID_HANDLE_VALUE then
    IcmpCloseHandle(hICMP);
  if hICMPdll <> 0 then
    FreeLibrary(hICMPdll);
  WSACleanup;
  inherited Destroy;
end;

{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
function MinInteger(X, Y: Integer): Integer;
begin
  if X >= Y then
    Result := Y
  else
    Result := X;
end;

{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
procedure TICMP.ResolveAddr;
var
  Phe: PHostEnt; // HostEntry buffer for name lookup
begin
  // Convert host address to IP address
  FIPAddress := inet_addr(PChar(FAddress));
  if FIPAddress <> INADDR_NONE then
    // Was a numeric dotted address let it in this format
    FHostName := FAddress
  else
  begin
    // Not a numeric dotted address, try to resolve by name
    Phe := GetHostByName(PChar(FAddress));
    if Phe = nil then
    begin
      FLastError := GetLastError;
      if Assigned(FOnDisplay) then
        FOnDisplay(Self, 'Unable to resolve ' + FAddress);
      Exit;
    end;
    FIPAddress := longint(plongint(Phe^.h_addr_list^)^);
    FHostName := Phe^.h_name;
  end;
  FHostIP := StrPas(inet_ntoa(TInAddr(FIPAddress)));
  FAddrResolved := TRUE;
end;

{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
procedure TICMP.SetAddress(Value: String);
begin
  // Only change if needed (could take a long time)
  if FAddress = Value then
    Exit;
  FAddress := Value;
  FAddrResolved := FALSE;
  // ResolveAddr;
end;

{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
function TICMP.GetErrorString: String;
begin
  case FLastError of
    IP_SUCCESS:
      Result := 'No error';
    IP_BUF_TOO_SMALL:
      Result := 'Buffer too small';
    IP_DEST_NET_UNREACHABLE:
      Result := 'Destination network unreachable';
    IP_DEST_HOST_UNREACHABLE:
      Result := 'Destination host unreachable';
    IP_DEST_PROT_UNREACHABLE:
      Result := 'Destination protocol unreachable';
    IP_DEST_PORT_UNREACHABLE:
      Result := 'Destination port unreachable';
    IP_NO_RESOURCES:
      Result := 'No resources';
    IP_BAD_OPTION:
      Result := 'Bad option';
    IP_HW_ERROR:
      Result := 'Hardware error';
    IP_PACKET_TOO_BIG:
      Result := 'Packet too big';
    IP_REQ_TIMED_OUT:
      Result := 'Request timed out';
    IP_BAD_REQ:
      Result := 'Bad request';
    IP_BAD_ROUTE:
      Result := 'Bad route';
    IP_TTL_EXPIRED_TRANSIT:
      Result := 'TTL expired in transit';
    IP_TTL_EXPIRED_REASSEM:
      Result := 'TTL expired in reassembly';
    IP_PARAM_PROBLEM:
      Result := 'Parameter problem';
    IP_SOURCE_QUENCH:
      Result := 'Source quench';
    IP_OPTION_TOO_BIG:
      Result := 'Option too big';
    IP_BAD_DESTINATION:
      Result := 'Bad Destination';
    IP_ADDR_DELETED:
      Result := 'Address deleted';
    IP_SPEC_MTU_CHANGE:
      Result := 'Spec MTU change';
    IP_MTU_CHANGE:
      Result := 'MTU change';
    IP_GENERAL_FAILURE:
      Result := 'General failure';
    IP_PENDING:
      Result := 'Pending';
  else
    Result := 'ICMP error #' + IntToStr(FLastError);
  end;
end;

{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
function TICMP.Ping: Integer;
var
  BufferSize: Integer;
  pReqData, pData: Pointer;
  pIPE: PIcmpEchoReply; // ICMP Echo reply buffer
  IPOpt: TIPOptionInformation; // IP Options for packet to send
  Msg: String;
begin
  Result := 0;
  FLastError := 0;
  if not FAddrResolved then
    ResolveAddr;
  if FIPAddress = INADDR_NONE then
  begin
    FLastError := IP_BAD_DESTINATION;
    if Assigned(FOnDisplay) then
      FOnDisplay(Self, 'Invalid host address');
    Exit;
  end;
  // Allocate space for data buffer space
  BufferSize := SizeOf(TIcmpEchoReply) + FSize;
  GetMem(pReqData, FSize);
  GetMem(pData, FSize);
  GetMem(pIPE, BufferSize);
  try
    // Fill data buffer with some data bytes
    FillChar(pReqData^, FSize, $20);
    Msg := 'Pinging from Delphi code written by F. Piette';
    Move(Msg[1], pReqData^, MinInteger(FSize, Length(Msg)));
    pIPE^.Data := pData;
    FillChar(pIPE^, SizeOf(pIPE^), 0);
    if Assigned(FOnEchoRequest) then
      FOnEchoRequest(Self);
    FillChar(IPOpt, SizeOf(IPOpt), 0);
    IPOpt.TTL := FTTL;
    Result := IcmpSendEcho(hICMP, FIPAddress, pReqData, FSize, @IPOpt, pIPE,
      BufferSize, FTimeOut);
    FLastError := GetLastError;
    FReply := pIPE^;
    if Assigned(FOnEchoReply) then
      FOnEchoReply(Self, Result);
  finally
    // Free those buffers
    FreeMem(pIPE);
    FreeMem(pData);
    FreeMem(pReqData);
  end;
end;

end.