Бесплатные компоненты

{ =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- }
{
 
    Author:                Franзois PIETTE
    Спёрто мной :)        2016-07-12 12:26:10
    И допилено напильником!
 
  А для 64-битной версии пришлось допиливать повторно.
  Конечно, можно плюхнуть компонент из пакета ICS на форму, но он тащит за собой
  кучу модулей и неприлично увеличивает размер ЕХЕшника.
  Поэтому, наткнувшись на факт ошибки в 64-битной версии программы, я полазил
  по интернетам, почитал MSDN, поковырял код в дебаггере и всё наладилось.
 
                                                  Verevkin, 2019-10-09 20:39:50.   }
{ =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- }
 
unit uICMPSocket;
 
interface
 
{$REGION 'uses'}
uses
  //=================== Системные модули, добавленные вручную ==================
  Windows, IpExport, Messages, SysUtils, Classes, WinSock;
{$ENDREGION}
 
{$REGION 'const'}
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;
{$ENDREGION}
 
{$REGION 'общие типы'}
type
  // IP types
  TIPAddr   = LongInt;   // An IP address.
  TIPMask   = LongInt;   // An IP subnet mask.
  TIPStatus = LongInt;   // Status code returned from IP APIs.
 
type
  // 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;
 
  TPingResult = (prUnknown, prInProgress, prHostOnline, prHostOffline);
  TICMPException = class(Exception);
{$ENDREGION}
 
{$REGION 'типы событий'}
  // Event handler type declaration for TICMP.OnDisplay event.
  TICMPDisplay = procedure(Sender: TObject; Msg : String) of object;
  TICMPReply   = procedure(Sender: TObject; Error : Integer) of object;
{$ENDREGION}
 
{$REGION 'TICMPSocket = class(TObject)'}
// The object wich encapsulate the ICMP.DLL
type
  TICMPSocket = 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)
    FFlags :          Integer;                    // Options flags
    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 Flags         : Integer        read  FFlags     write FFlags;
    property ErrorCode     : DWORD          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;
{$ENDREGION}
 
{$REGION 'TPingThread = class(TThread)'}
type
    TPingThread = class(TThread)
    private
        FIcmp: TICMPSocket;
    public
        PingHostName: string ;      // host name or IP address to ping
        PingLookupReply: boolean ;  // if true, ReplyAddress is reverse DNS looked-up to ReplyHostName
        PingSize: Integer ;         // bytes of data to ping
        PingTimeout: Integer ;      // milliseconds ping timeout
        PingTTL: Integer ;          // ping Time To Live, to stop ping short of host
        PingFlags: Integer ;        // ping options
        PingId: integer ;           // available in terminate event to distinguish multiple pings
        PingThreadNum: integer ;    // thread number (not ThreadId) to used in terminate event to remove thread
        DnsHostIP: String ;         // IP address looked up for PingHostName
        ReplyIPAddr: String ;       // Replying IP address (integer)
        ReplyStatus: DWORD ;        // IP status value
        ReplyRTT: DWORD ;           // Round Trip Time in milliseconds
        ReplyDataSize: Word ;       // Reply data size
        ReplyTotal: integer ;       // Number of replies to ping
        ReplyHostName: String ;     // Reply host name (if PingLookupReply=true)
        ErrCode: Integer ;          // non-zero ping or DNS error
        ErrString: String ;         // error literal if errcode non-zero
 
        procedure Execute; override;
    public
        property ReturnValue; // (+21 ноя 2020)
    end;
{$ENDREGION}
 
{$REGION 'глобальные переменные'}
var
// list of thread Ids allocated for TPingThread, so they can be stopped
    PingThreadList: array of Cardinal;
{$ENDREGION}
 
{$REGION 'прототипы'}
function PingAddThread (ThreadId: Cardinal): integer ;
procedure PingRemoveThread (ThreadNum: integer) ;
procedure PingTerm1Thread (ThreadNum: integer) ;
procedure PingTermAllThreads ;
function LongAddr2Dotted (IPAddr: string): string ;
{$ENDREGION}
 
implementation
 
uses uWinsockUtils;
 
{$REGION 'TICMPSocket'}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TICMPSocket.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 TICMPSocket.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 TICMPSocket.ResolveAddr;
var
    Phe : PHostEnt;             // HostEntry buffer for name lookup
begin
    // Convert host address to IP address
    FIPAddress := inet_addr(PChar(FAddress));
    if FIPAddress <> LongInt(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  := string(Phe^.h_name);
    end;
 
    FHostIP       := inet_ntoa(TInAddr(FIPAddress));  //StrPas(inet_ntoa(TInAddr(FIPAddress)));
    FAddrResolved := TRUE;
end;
 
 
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TICMPSocket.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 TICMPSocket.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 TICMPSocket.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 = LongInt(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;
        IPOpt.Flags := FFlags;
        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;
{$ENDREGION}
 
var
    num4: longword ;   // used for converting long IP address to dots
    num1: array [1..4] of byte absolute num4 ;
 
{$REGION 'TPingThread'}
//------------------------------------------------------------------------------
//---- TPingThread -------------------------------------------------------------
//------------------------------------------------------------------------------
 
procedure TPingThread.Execute;
var
  ReplyIp: TIPAddr;
  HostEnt: PHostEnt;
begin
  FIcmp:= TICMPSocket.Create();
  try
    // see if overriding default parameters
    if PingSize <> 0
      then FIcmp.Size:= PingSize;
 
    if PingTimeout <> 0
      then FIcmp.Timeout:= PingTimeout;
 
    if PingTTL <> 0
      then FIcmp.TTL:= PingTTL;
 
    FIcmp.Flags:=   PingFlags;
    FIcmp.Address:= trim(PingHostName);
 
    // blocking ping, will also lookup IP address if required
    ReplyTotal:= FIcmp.Ping();
    DnsHostIP:=  FIcmp.HostIP;
 
    if ReplyTotal <> 0
      then begin
             ErrCode:= 0;
             // PingTTL:= FIcmp.Reply.Options.TTL;  // not sure if this gets updated
             ReplyIp:=       FIcmp.Reply.Address;
             ReplyIPAddr:=   inet_ntoa (in_addr (ReplyIp));
             ReplyHostName:= ReplyIPAddr;    // may get reversed looked up
             ReplyStatus:=   FIcmp.Reply.Status;
             ReplyRTT:=      FIcmp.Reply.RoundTripTime;
             ReplyDataSize:= FIcmp.Reply.DataSize;
 
             // see if now looking up host name for reply address,
             // which might not be the same address ping if TTL was less
             if PingLookupReply and (ReplyIp <> 0)
               then begin
                      HostEnt:= GetHostByAddr(@ReplyIp, 4, PF_INET);
                      if HostEnt <> nil
                        then ReplyHostName:= string(HostEnt^.h_name); //StrPas (HostEnt^.h_name);
                    end;
           end
      else begin       // ping failed
             ErrCode:=   FIcmp.ErrorCode;
             ErrString:= FIcmp.ErrorString;
           end;
  finally
    FIcmp.Free(); //Destroy;
    Terminate();
  end;
end;
 
//------------------------------------------------------------------------------
 
// keep ping ThreadId so it may be freed if it gets stuck
 
function PingAddThread (ThreadId: Cardinal): integer ;
begin
    SetLength (PingThreadList, Succ (Length (PingThreadList))) ;
    result := Length (PingThreadList) ;
    PingThreadList [Pred (result)] := ThreadId ;
end ;
 
//------------------------------------------------------------------------------
 
// remove ping ThreadId now it's finished
 
procedure PingRemoveThread (ThreadNum: integer) ;
begin
    if (ThreadNum > Length (PingThreadList)) or (ThreadNum = 0) then exit ;
    PingThreadList [Pred (ThreadNum)] := 0 ;
end ;
 
//------------------------------------------------------------------------------
 
// force ping thread to quit
 
procedure PingTerm1Thread (ThreadNum: integer) ;
var
    ThreadId: Cardinal ;
    I: integer ;
begin
    if (ThreadNum > Length (PingThreadList)) or (ThreadNum = 0) then exit ;
    ThreadId := PingThreadList [Pred (ThreadNum)] ;
    if ThreadId <> 0 then
            PostThreadMessage (ThreadId, WM_QUIT, 0, 0);  // terminate thread
    PingThreadList [Pred (ThreadNum)] := 0 ;              // remove from list
 
// if freed all threads, free memory
    for I := 1 to Length (PingThreadList) do
    begin
        if PingThreadList [Pred (I)] <> 0 then exit ;
    end ;
    SetLength (PingThreadList, 0) ;
end ;
 
//------------------------------------------------------------------------------
 
// force all pending ping threads to quit
 
procedure PingTermAllThreads;
var
    I: integer;
begin
    if Length (PingThreadList) <> 0 then
    begin
        for I := 1 to Length (PingThreadList) do PingTerm1Thread (I) ;
        SetLength (PingThreadList, 0) ;
    end ;
end;
 
//------------------------------------------------------------------------------
 
// convert long IP numeric address (ie 12345678) into a dotted address
 
function LongAddr2Dotted (IPAddr: string): string ;
var
    I: integer ;
begin
    result := trim (IPAddr) ;
    if pos ('.', IPAddr) > 0 then exit ;  // got a dotted address
    try
        num4 := StrToInt64 (IPAddr) ;
    except ;
        exit ;
    end ;
    if num4 = 0 then exit ;
    result := '' ;
    for I := 4 downto 1 do
    begin
        result := result + IntToStr (num1 [I]) ;
        if I = 1 then exit ;
        result := result + '.' ;
    end ;
end ;
{$ENDREGION}
 
//------------------------------------------------------------------------------
 
Initialization
    SetLength(PingThreadList, 0) ;
 
Finalization
    PingTermAllThreads();
 
end.

делай в виде страницы в HTML