Delphi2010Ping某IP是否连通的代码实现

      很多时候不检查局域网内的IP是否连通，直接通过IP访问，程序会卡住很久，有1分钟左右，这给用户的体验非常不好，现在通过检查是否连通，设置为1.5S后不连通则不进行后面的操作，程序效率大大提升，如下是检查局域网内的IP或者外网的IP是否连通的实现。

      后面的代码直接保存为Ping.Pas，即可直接使用，下面是使用方法 ：

  var
  str: string;
  ping: Tping;
  isconOK: Boolean;
begin
  ping := Tping.create; //一定要初试化,否则下次打开会卡住程序
  ping.pinghost('192.168.1.100', str, isconOK); //ping IP 192.168.1.100  //
  ping.destroy;
 if isconOK then
 begin   //IP能ping通，则进行更新 .否则不进行更新，这是为了避免 长时间等待
   ShowMessage('ping OK');
 end;
end;

 如下是Ping.pas文件的所有内容
unit Ping;


interface


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


type
  PIPOptionInformation = ^TIPOptionInformation;


  TIPOptionInformation = packed record
    TTL: Byte;
    TOS: Byte;
    Flags: Byte;
    OptionsSize: Byte;
    OptionsData: PChar;
  end;


  PIcmpEchoReply = ^TIcmpEchoReply;


  TIcmpEchoReply = packed record
    Address: DWORD;
    Status: DWORD;
    RTT: DWORD;
    DataSize: Word;
    Reserved: Word;
    Data: Pointer;
    Options: TIPOptionInformation;
  end;


  TIcmpCreateFile = function: THandle; stdcall;


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


  TIcmpSendEcho = function(IcmpHandle: THandle; DestinationAddress: //
    DWORD; RequestData: Pointer; RequestSize: Word; RequestOptions:   //
    PIPOptionInformation; ReplyBuffer: Pointer; ReplySize: DWord; Timeout: DWord): DWord; stdcall;


  Tping = class(Tobject)
  private
{ Private declarations }
    hICMP: THANDLE;
    IcmpCreateFile: TIcmpCreateFile;
    IcmpCloseHandle: TIcmpCloseHandle;
    IcmpSendEcho: TIcmpSendEcho;
  public
    procedure pinghost(ip: string; var info: string; var IsConnectedOk: Boolean);
    constructor create;
    destructor destroy; override;
{ Public declarations }
  end;


var
  hICMPdll: HMODULE;


implementation


constructor Tping.create;
begin
  inherited create;
  hICMPdll := LoadLibrary('icmp.dll');
  @ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');
  @IcmpCloseHandle := GetProcAddress(hICMPdll, 'IcmpCloseHandle');
  @IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');
  hICMP := IcmpCreateFile;


end;


destructor Tping.destroy;
begin
  FreeLibrary(hIcmpDll);
  inherited destroy;
end;


procedure Tping.pinghost(ip: string; var info: string; var IsConnectedOk: Boolean);
var
// IP Options for packet to send
  IPOpt: TIPOptionInformation;
  FIPAddress: DWORD;
  pReqData, pRevData: PChar;
// ICMP Echo reply buffer
  pIPE: PIcmpEchoReply;
  FSize: DWORD;
  MyString: string;
  FTimeOut: DWORD;
  BufferSize: DWORD;
  isConnected: Integer;
begin
  if ip <> '' then
  begin
   // FIPAddress := inet_addr(PChar(ip));//Delphi 7
    IsConnectedOk := False;
    FIPAddress := inet_addr(PAnsiChar(AnsiString(ip)));
    isConnected := 0;
    FSize := 40;
    BufferSize := SizeOf(TICMPEchoReply) + FSize;
    GetMem(pRevData, FSize);
    GetMem(pIPE, BufferSize);
    FillChar(pIPE^, SizeOf(pIPE^), 0);
    pIPE^.Data := pRevData;
    MyString := 'Test Net – Sos Admin';
    pReqData := PChar(MyString);
    FillChar(IPOpt, Sizeof(IPOpt), 0);
    IPOpt.TTL := 64;
    FTimeOut := 1500;     //连接时间，1500MS 1.5S后停止
    try
      isConnected := IcmpSendEcho(hICMP, FIPAddress, pReqData, Length(MyString), //
        @IPOpt, pIPE, BufferSize, FTimeOut);
      if isConnected = 1 then
      begin
        info := '连通';
        IsConnectedOk := True;
      end
      else
      begin
        info := '不连通';
        IsConnectedOk := False;
      end;
      info := info + ' ' + ip + '  time= ' + IntToStr(pIPE^.RTT);
//      if pReqData^ = pIPE^.Options.OptionsData^then
//        info := ip + ' ' + IntToStr(pIPE^.DataSize) + '　　　' + IntToStr(pIPE^.RTT);
    except
      info := 'Can not find host!';
      FreeMem(pRevData);
      FreeMem(pIPE);
      Exit;
    end;
    FreeMem(pRevData);
    FreeMem(pIPE);
  end;
end;


end.