Delphi 实现Ping命令

Delphi  实现Ping命令

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 )

        Flags: Byte; // IP header flags (usually )

        OptionsSize: Byte; // Size of options data (usually , max )

        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 ;

        {* 调用Ping方法时进行多少次数据发送，默认是4次。}

        property Delay: Integer read FDelay write FDelay default ;

        {* 相邻两次 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 = ;

procedure InitIcmpFunctions;

begin

    IcmpDllHandle := LoadLibrary( ICMPDLL );

    if IcmpDllHandle <>  then

        begin

            @IcmpCreateFile := GetProcAddress( IcmpDllHandle, 'IcmpCreateFile' );

            @IcmpCloseHandle := GetProcAddress( IcmpDllHandle, 'IcmpCloseHandle' );

            @IcmpSendEcho := GetProcAddress( IcmpDllHandle, 'IcmpSendEcho' );

        end;

end;

procedure FreeIcmpFunctions;

begin

    if IcmpDllHandle <>  then

        FreeLibrary( IcmpDllHandle );

end;

//==============================================================================

// Ping 通讯类

//==============================================================================

{ TFtPing }

constructor TFtPing.Create( AOwner: TComponent );

begin

    inherited Create( AOwner );

    FRemoteIP := '127.0.0.1';

    FTTL := ;

    FPingCount := ;

    FDelay := ;

    FTimeOut := ;

    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 >  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 ) >= ;

end;

function TFtPing.Ping( var aReply: string ): Boolean;

var

    iCount, iResult: Integer;

    sReply: string;

begin

    aReply := '';

    iResult := ;

    try

        SetIP( RemoteIP, RemoteHost, FIP );

        for iCount :=  to PingCount do

            begin

                iResult := PingIP_Host( FIP, Pointer( FDataString )^, Length( DataString ) * SizeOf( Char ), sReply );

                aReply := aReply + ## + sReply;

                if iResult <  then

                    Break;

                if FDelay >  then

                    Sleep( FDelay );

            end;

    finally

        Result := iResult >= ;

    end;

end;

function TFtPing.PingOnce( var aReply: string ): Boolean;

begin

    SetIP( RemoteIP, RemoteHost, FIP );

    Result := PingIP_Host( FIP, pointer( FDataString )^, Length( DataString ), aReply ) >= ;

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 ) >= ;

end;

function TFtPing.PingFromBuffer( var Buffer; Count: Integer; var aReply: string ): Boolean;

begin

    SetIP( RemoteIP, RemoteHost, FIP );

    Result := PingIP_Host( FIP, Buffer, Count, aReply ) >= ;

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 := -;

    pReqData := nil;

    if Count <=  then

        begin

            aReply := GetReplyString( Result, aIP, nil );

            Exit;

        end;

    if aIP.Address = INADDR_NONE then

        begin

            Result := -;

            aReply := GetReplyString( Result, aIP, nil );

            Exit;

        end;

    GetMem( pCIER, SizeOf( TCnICMPEchoReply ) + Count );

    GetMem( pRevData, Count );

    try

        FillChar( pCIER^, SizeOf( TCnICMPEchoReply ) + Count,  ); // 初始化接收数据结构

        pCIER^.Data := pRevData;

        GetMem( pReqData, Count );

        Move( Data, pReqData^, Count ); // 准备发送的数据

        FillChar( IPOpt, Sizeof( IPOpt ),  ); // 初始化发送数据结构

        IPOpt.TTL := FTTL;

        try //Ping开始

            if WSAStartup( MAKEWORD( ,  ), FWSAData ) <>  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

                ) <>  then

                begin

                    Result := ; // Ping正常返回

                    if Assigned( FOnReceived ) then

                        FOnReceived( Self, aIP.IP, aIP.Host, IPOpt.TTL, IPOpt.TOS );

                end

            else

                begin

                    Result := -; // 没有响应

                    if Assigned( FOnError ) then

                        FOnError( Self, aIP.IP, aIP.Host, IPOpt.TTL, IPOpt.TOS, SNoResponse );

                end;

        except

            on E: Exception do

                begin

                    Result := -; // 发生错误

                    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

        -: Result := SICMPRunError;

        -: Result := SInvalidAddr;

        -: 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[ .. ] of AnsiChar;

begin

    Result := False;

    //    StrPCopy(sName, {$IFDEF DELPHI12_UP}AnsiString{$ENDIF}(aName));

    StrPCopy( sName, AnsiString( aName ) );

    aIP := '';

    if aName = '' then

        Exit;

    WSAStartup( $, 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 ) +  );

    try

        ZeroMemory( pIPAddr, Length( aIP.IP ) +  );

        //        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;

}

正则取匹配IP地址

 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  没有获取到ＩＰ地址