unit FtPing;

interface


uses
    Windows, SysUtils, Classes, Controls, Winsock, StdCtrls;

resourcestring
    SICMPRunError = 'ICMP Run Error';
    SInitFailed = 'Init Failed. Maybe Winsock Verison Error';
    SNoResponse = '[%0:S] No Response';
    SInvalidAddr = 'IP Address Error';
    SPingResultString = '[%0:S]: Bytes:%1:D Time: %2:Dms  TTL:%3:D';

type

    PCnIPOptionInformation = ^TCnIPOptionInformation;
    TCnIPOptionInformation = 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: PAnsiChar; // Options data buffer
    end;

    PCnIcmpEchoReply = ^TCnIcmpEchoReply;
    TCnIcmpEchoReply = packed record
        Address: DWORD; // replying address
        Status: DWORD; // IP status value (see below)
        RTT: DWORD; // Round Trip Time in milliseconds
        DataSize: Word; // reply data size
        Reserved: Word;
        Data: Pointer; // pointer to reply data buffer
        Options: TCnIPOptionInformation; // reply options
    end;

    TIpInfo = record
        Address: Int64;
        IP: string;
        Host: string;
    end;

    TOnReceive = procedure( Sender: TComponent; IPAddr, HostName: string; TTL, TOS: Byte ) of object;

    TOnError = procedure( Sender: TComponent; IPAddr, HostName: string; TTL, TOS: Byte; ErrorMsg: string ) of object;

    //==============================================================================
    // Ping 通讯类
    //==============================================================================

      { TFtPing }

    TFtPing = class( TComponent )
        {* 通过调用ICMP.DLL库中的函数来实现Ping功能。}
    private
        hICMP: THANDLE;
        FRemoteHost: string;
        FRemoteIP: string;
        FIPAddress: Int64;
        FTTL: Byte;
        FTimeOut: DWord;
        FPingCount: Integer;
        FDelay: Integer;
        FOnError: TOnError;
        FOnReceived: TOnReceive;
        FDataString: string;
        FWSAData: TWSAData;
        FIP: TIpInfo;

        procedure SetPingCount( const Value: Integer );
        procedure SetRemoteHost( const Value: string );
        procedure SetTimeOut( const Value: DWord );
        procedure SetTTL( const Value: Byte );
        procedure SetDataString( const Value: string );
        procedure SetRemoteIP( const Value: string );
        function PingIP_Host( const aIP: TIpInfo; const Data; Count: Cardinal; var aReply: string ): Integer;
        {* 以设定的数据Data(无类型缓冲区)Ping一次并返回结果。Count表示数据长度 }
        function GetReplyString( aResult: Integer; aIP: TIpInfo; pIPE: PCnIcmpEchoReply ): string;
        {* 返回结果字符串。}
        function GetDataString: string;
        function GetIPByName( const aName: string; var aIP: string ): Boolean;
        {* 通过机器名称获取IP地址}
        function SetIP( aIPAddr, aHost: string; var aIP: TIpInfo ): Boolean;
        {* 通过机器名称或IP地址填充完整IP信息}
    protected

    public
        constructor Create( AOwner: TComponent ); override;
        destructor Destroy; override;

        function IsOnline: Boolean;

        function Ping( var aReply: string ): Boolean;
        {* 进行循环Ping,循环次数在PingCount属性中指定。}
        function PingOnce( var aReply: string ): Boolean; overload;
        {* 以设定的数据Ping一次并返回结果。}
        function PingOnce( const aIP: string; var aReply: string ): Boolean; overload;
        {* 向指定IP进行一次Ping并返回结果。}
        function PingFromBuffer( var Buffer; Count: Longint; var aReply: string ): Boolean;
        {* 以参数Buffer的数据Ping一次并读取返回结果。}
    published
        property RemoteIP: string read FRemoteIP write SetRemoteIP;
        {* 要Ping的目标主机地址，只支持ip}
        property RemoteHost: string read FRemoteHost write SetRemoteHost;
        {* 要ping的目标主机名，有主机名存在时会覆盖 RemoteIP 的内容}
        property PingCount: Integer read FPingCount write SetPingCount default 4;
        {* 调用Ping方法时进行多少次数据发送，默认是4次。}
        property Delay: Integer read FDelay write FDelay default 0;
        {* 相邻两次 Ping 间的时间间隔，单位毫秒，默认 0 也就是不延时}
        property TTL: Byte read FTTL write SetTTL;
        {* 设置的TTL值，Time to Live}
        property TimeOut: DWord read FTimeOut write SetTimeOut;
        {* 设置的超时值}
        property DataString: string read GetDataString write SetDataString;
        {* 欲发送的数据，以字符串形式表示，默认为"CnPack Ping"。}
        property OnReceived: TOnReceive read FOnReceived write FOnReceived;
        {* Ping一次成功时返回数据所触发的事件}
        property OnError: TOnError read FOnError write FOnError;
        {* Ping出错时返回的内容和信息。包括目的未知、不可达、超时等。}
    end;

implementation

{$R-}

const
    SCnPingData = 'FtPack Ping.';
    ICMPDLL = 'icmp.dll';

type

    //==============================================================================
    // 辅助过程  从icmp.dll导入的函数
    //==============================================================================

    TIcmpCreateFile = function( ): THandle; stdcall;

    TIcmpCloseHandle = function( IcmpHandle: THandle ): Boolean; stdcall;

    TIcmpSendEcho = function( IcmpHandle: THandle;
        DestAddress: DWORD;
        RequestData: Pointer;
        RequestSize: Word;
        RequestOptions: PCnIPOptionInformation;
        ReplyBuffer: Pointer;
        ReplySize: DWord;
        TimeOut: DWord ): DWord; stdcall;

var
    IcmpCreateFile: TIcmpCreateFile = nil;
    IcmpCloseHandle: TIcmpCloseHandle = nil;
    IcmpSendEcho: TIcmpSendEcho = nil;

    IcmpDllHandle: THandle = 0;

procedure InitIcmpFunctions;
begin
    IcmpDllHandle := LoadLibrary( ICMPDLL );
    if IcmpDllHandle <> 0 then
        begin
            @IcmpCreateFile := GetProcAddress( IcmpDllHandle, 'IcmpCreateFile' );
            @IcmpCloseHandle := GetProcAddress( IcmpDllHandle, 'IcmpCloseHandle' );
            @IcmpSendEcho := GetProcAddress( IcmpDllHandle, 'IcmpSendEcho' );
        end;
end;

procedure FreeIcmpFunctions;
begin
    if IcmpDllHandle <> 0 then
        FreeLibrary( IcmpDllHandle );
end;

//==============================================================================
// Ping 通讯类
//==============================================================================

{ TFtPing }

constructor TFtPing.Create( AOwner: TComponent );
begin
    inherited Create( AOwner );
    FRemoteIP := '127.0.0.1';
    FTTL := 64;
    FPingCount := 4;
    FDelay := 0;
    FTimeOut := 10;
    FDataString := SCnPingData;

    hICMP := IcmpCreateFile( ); // 取得DLL句柄
    if hICMP = INVALID_HANDLE_VALUE then
        begin
            raise Exception.Create( SICMPRunError );
        end;
end;



destructor TFtPing.Destroy;
begin
    if hICMP <> INVALID_HANDLE_VALUE then
        begin
            IcmpCloseHandle( hICMP );
        end;
    inherited Destroy;
end;



procedure TFtPing.SetPingCount( const Value: Integer );
begin
    if Value > 0 then
        FPingCount := Value;
end;



procedure TFtPing.SetRemoteIP( const Value: string );
begin
    if FRemoteIP <> Value then
        begin
            FRemoteIP := Value;
            if SetIP( FRemoteIP, '', FIP ) then
                begin
                    FRemoteHost := FIP.Host;
                    FIPAddress := FIP.Address;
                end;
        end;
end;



procedure TFtPing.SetRemoteHost( const Value: string );
begin
    if FRemoteHost <> Value then
        begin
            // RemoteHost 更改的话，RemoteIP 自动清空
            FRemoteHost := Value;
            if SetIP( '', FRemoteHost, FIP ) then
                begin
                    FRemoteIP := FIP.IP;
                    FIPAddress := FIP.Address;
                end;
        end;
end;


procedure TFtPing.SetTimeOut( const Value: DWord );
begin
    FTimeOut := Value;
end;



procedure TFtPing.SetTTL( const Value: Byte );
begin
    FTTL := Value;
end;



procedure TFtPing.SetDataString( const Value: string );
begin
    FDataString := Value;
end;



function TFtPing.GetDataString: string;
begin
    if FDataString = '' then
        FDataString := SCnPingData;
    Result := FDataString;
end;



function TFtPing.IsOnline: Boolean;
var
    sReply: string;
begin
    SetIP( RemoteIP, RemoteHost, FIP );
    Result := PingIP_Host( FIP, pointer( FDataString )^, Length( DataString ), sReply ) >= 0;
end;


function TFtPing.Ping( var aReply: string ): Boolean;
var
    iCount, iResult: Integer;
    sReply: string;
begin
    aReply := '';
    iResult := 0;
    try
        SetIP( RemoteIP, RemoteHost, FIP );
        for iCount := 1 to PingCount do
            begin
                iResult := PingIP_Host( FIP, Pointer( FDataString )^, Length( DataString ) * SizeOf( Char ), sReply );
                aReply := aReply + #13#10 + sReply;
                if iResult < 0 then
                    Break;

                if FDelay > 0 then
                    Sleep( FDelay );
            end;
    finally
        Result := iResult >= 0;
    end;
end;



function TFtPing.PingOnce( var aReply: string ): Boolean;
begin
    SetIP( RemoteIP, RemoteHost, FIP );
    Result := PingIP_Host( FIP, pointer( FDataString )^, Length( DataString ), aReply ) >= 0;
end;


function TFtPing.PingOnce( const aIP: string; var aReply: string ): Boolean;
begin
    SetIP( aIP, aIP, FIP );
    Result := PingIP_Host( FIP, pointer( FDataString )^, Length( DataString ), aReply ) >= 0;
end;



function TFtPing.PingFromBuffer( var Buffer; Count: Integer; var aReply: string ): Boolean;
begin
    SetIP( RemoteIP, RemoteHost, FIP );
    Result := PingIP_Host( FIP, Buffer, Count, aReply ) >= 0;
end;



function TFtPing.PingIP_Host( const aIP: TIpInfo; const Data; Count: Cardinal; var aReply: string ): Integer;
var
    IPOpt: TCnIPOptionInformation; // 发送数据结构
    pReqData, pRevData: PAnsiChar;
    pCIER: PCnIcmpEchoReply;
begin
    Result := -100;
    pReqData := nil;

    if Count <= 0 then
        begin
            aReply := GetReplyString( Result, aIP, nil );
            Exit;
        end;
    if aIP.Address = INADDR_NONE then
        begin
            Result := -1;
            aReply := GetReplyString( Result, aIP, nil );
            Exit;
        end;

    GetMem( pCIER, SizeOf( TCnICMPEchoReply ) + Count );
    GetMem( pRevData, Count );
    try
        FillChar( pCIER^, SizeOf( TCnICMPEchoReply ) + Count, 0 ); // 初始化接收数据结构
        pCIER^.Data := pRevData;
        GetMem( pReqData, Count );
        Move( Data, pReqData^, Count ); // 准备发送的数据
        FillChar( IPOpt, Sizeof( IPOpt ), 0 ); // 初始化发送数据结构
        IPOpt.TTL := FTTL;

        try //Ping开始
            if WSAStartup( MAKEWORD( 2, 0 ), FWSAData ) <> 0 then
                raise Exception.Create( SInitFailed );
            if IcmpSendEcho( hICMP, //dll handle
                aIP.Address, //target
                pReqData, //data
                Count, //data length
                @IPOpt, //addree of ping option
                pCIER,
                SizeOf( TCnICMPEchoReply ) + Count, //pack size
                FTimeOut //timeout value
                ) <> 0 then
                begin
                    Result := 0; // Ping正常返回
                    if Assigned( FOnReceived ) then
                        FOnReceived( Self, aIP.IP, aIP.Host, IPOpt.TTL, IPOpt.TOS );
                end
            else
                begin
                    Result := -2; // 没有响应
                    if Assigned( FOnError ) then
                        FOnError( Self, aIP.IP, aIP.Host, IPOpt.TTL, IPOpt.TOS, SNoResponse );
                end;
        except
            on E: Exception do
                begin
                    Result := -3; // 发生错误
                    if Assigned( FOnError ) then
                        FOnError( Self, aIP.IP, aIP.Host, IPOpt.TTL, IPOpt.TOS, E.Message );
                end;
        end;
    finally
        WSACleanUP;
        aReply := GetReplyString( Result, aIP, pCIER );
        if pRevData <> nil then
            begin
                FreeMem( pRevData ); // 释放内存
                pCIER.Data := nil;
            end;
        if pReqData <> nil then
            FreeMem( pReqData ); //释放内存
        FreeMem( pCIER ); //释放内存
    end;
end;



function TFtPing.GetReplyString( aResult: Integer; aIP: TIpInfo;
    pIPE: PCnIcmpEchoReply ): string;
var
    sHost: string;
begin
    Result := SInvalidAddr;
    case aResult of
        -100: Result := SICMPRunError;
        -1: Result := SInvalidAddr;
        -2: Result := Format( SNoResponse, [ RemoteHost ] );
        else
            if pIPE <> nil then
                begin
                    sHost := aIP.IP;
                    if aIP.Host <> '' then
                        sHost := aIP.Host + ': ' + sHost;
                    Result := ( Format( SPingResultString, [ sHost, pIPE^.DataSize, pIPE^.RTT,
                        pIPE^.Options.TTL ] ) );
                end;
    end;
end;


function TFtPing.GetIPByName( const aName: string;
    var aIP: string ): Boolean;
var
    pHost: PHostEnt;
    FWSAData: TWSAData;
    sName: array[ 0..255 ] of AnsiChar;
begin
    Result := False;
    //    StrPCopy(sName, {$IFDEF DELPHI12_UP}AnsiString{$ENDIF}(aName));
    StrPCopy( sName, AnsiString( aName ) );
    aIP := '';
    if aName = '' then
        Exit;

    WSAStartup( $101, FWSAData );
    try
        pHost := GetHostByName( @sName );
        Result := pHost <> nil;
        if Result then
            //            aIP := {$IFDEF DELPHI12_UP}string{$ENDIF}(inet_ntoa(PInAddr(pHost^.h_addr_list^)^));
            aIP := string( inet_ntoa( PInAddr( pHost^.h_addr_list^ )^ ) );
    finally
        WSACleanup;
    end;
end;



function TFtPing.SetIP( aIPAddr, aHost: string; var aIP: TIpInfo ): Boolean;
var
    pIPAddr: PAnsiChar;
begin
    Result := False;
    aIP.Address := INADDR_NONE;
    aIP.IP := aIPAddr;
    aIP.Host := aHost;
    if aIP.IP = '' then
        begin
            if ( aIP.Host = '' ) or ( not GetIPByName( aIP.Host, aIP.IP ) ) then
                Exit;
        end;

    GetMem( pIPAddr, Length( aIP.IP ) + 1 );
    try
        ZeroMemory( pIPAddr, Length( aIP.IP ) + 1 );
        //        StrPCopy(pIPAddr, {$IFDEF DELPHI12_UP}AnsiString{$ENDIF}(aIP.IP));
        StrPCopy( pIPAddr, AnsiString( aIP.IP ) );
        aIP.Address := inet_addr( PAnsiChar( pIPAddr ) ); // IP转换成无点整型
    finally
        FreeMem( pIPAddr ); // 释放申请的动态内存
    end;
    Result := aIP.Address <> INADDR_NONE;
end;



initialization
    InitIcmpFunctions;



finalization
    FreeIcmpFunctions;

end.


{
  调用方法
procedure TForm1.Button1Click( Sender: TObject );
var
    FtPing: TFtPing;
    aReply: string;
begin
    FtPing := TFtPing.Create( nil );
    try
        FtPing.RemoteIP := Edit1.Text;
        if FtPing.Ping( aReply ) then
            begin
                Memo1.Lines.Add( '网络畅通！' )
            end
        else
            begin
                Memo1.Lines.Add( '网络异常~~>|<~~' )
            end;
    finally
        FtPing.Free;
    end;
end;

}

 Reg:=TPerlRegEx.Create;
      Reg.Subject:=pos.ServerUrl;
      Reg.RegEx:='((2[0-4]\d|25[0-5]|[01]?\d\d?)\.){3}(2[0-4]\d|25[0-5]|[01]?\d\d?)';

      if  reg.Match then
 IP:=Reg.MatchedText
else  
 //TODO  没有获取到ＩＰ地址