Delphi 实现Ping命令
unit FtPing;interfaceuses 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;} 正则取匹配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.MatchedTextelse //TODO 没有获取到ＩＰ地址