Delphi 实现Ping命令

许胖胖 發表於 2019-9-25 10:58:00

Delphi  实现Ping命令
<div class="cnblogs_code"><img id="code_img_closed_f2181539-440c-403f-95e1-5129c437a0dd" class="code_img_closed lazyload" alt="" data-src="http://images.cnblogs.com/OutliningIndicators/ContractedBlock.gif"><img id="code_img_opened_f2181539-440c-403f-95e1-5129c437a0dd" class="code_img_opened lazyload" style="display: none" alt="" data-src="http://images.cnblogs.com/OutliningIndicators/ExpandedBlockStart.gif">
<div id="cnblogs_code_open_f2181539-440c-403f-95e1-5129c437a0dd" class="cnblogs_code_hide">
<pre>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:DmsTTL:%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;

}</pre>
</div>
View Code</div>
正则取匹配IP地址
<div class="cnblogs_code">
<pre> Reg:=TPerlRegEx.Create;
 Reg.Subject:=pos.ServerUrl;
 Reg.RegEx:='((2\d|25|?\d\d?)\.){3}(2\d|25|?\d\d?)';

 ifreg.Match then
IP:=Reg.MatchedText
else
//TODO没有获取到ＩＰ地址 </pre>
</div>
 
   
来源：https://www.cnblogs.com/stroll/p/11583338.html

頁: [1]

琼殿技术论坛's Archiver

Delphi 实现Ping命令