高分：如何用Delphi程式实现Ping的功能？（在线,OK立即给分)

Question

如何用Delphi程式实现Ping的功能？

Answer 1

unit PingClass;interfaceuses
  Classes, Windows, WinSock, ScktComp, MMSystem;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;  Const PING_DLL = 'icmp.dll';  function TIcmpCreateFile: THandle; stdcall; external PING_DLL name 'IcmpCreateFile';
  function TIcmpCloseHandle(IcmpHandle: THandle): Boolean; stdcall; external PING_DLL name 'IcmpCloseHandle';
  function TIcmpSendEcho(IcmpHandle:THandle; DestinationAddress:DWORD;
                        RequestData: Pointer; RequestSize: Word;
                        RequestOptions: PIPOptionInformation; ReplyBuffer: Pointer;
                        ReplySize: DWord; Timeout: DWord ):DWord; stdcall; external PING_DLL name 'IcmpSendEcho';
type
  TPing = class(TThread)
  private
    { Private declarations }
    hICMP: THANDLE;
    hCSocket: TClientSocket;
  protected
    procedure Execute; override;
    procedure INI_PING;
    procedure _INI_PING;
    Function PING(Add, Msg: String; TimeOut: DWord): Boolean;
    Procedure CheckPing;
  Public
    constructor Create(CSocket: TClientSocket);
    destructor Destroy; override;
  end;implementationconstructor TPing.Create(CSocket: TClientSocket);
begin
  hCSocket := CSocket;
  INI_PING;
  inherited Create(True);
end;procedure TPing.Execute;
Begin
  { Place thread code here }
  While Not Terminated Do Begin
    Synchronize(CheckPing); //异部执行
    Sleep(5000);
  End;
end;procedure TPing._INI_PING;
begin
  TIcmpCloseHandle(hICMP);
end;procedure TPing.INI_PING;
begin
  hICMP := TIcmpCreateFile;
end;function TPing.PING(Add, Msg: String; TimeOut: DWord): Boolean;
var
  IPOpt: TIPOptionInformation;
  pIPE: PIcmpEchoReply;
  FSize: DWORD;
  FIPAddress: DWORD;  pReqData, pRevData: PChar;
  BufferSize: DWORD;
Begin
  Result := False;
  FIPAddress := inet_addr(PChar(Add));
  FSize := 40;
  BufferSize := SizeOf(TICMPEchoReply) + FSize;
  GetMem(pRevData, FSize);
  GetMem(pIPE, BufferSize);  FillChar(pIPE^, SizeOf(pIPE^), 0);
  pIPE^.Data := pRevData;
  pReqData := PChar(Msg);  FillChar(IPOpt, Sizeof(IPOpt), 0);
  IPOpt.TTL := 64;  TIcmpSendEcho(hICMP, FIPAddress, pReqData, FSize, @IPOpt, pIPE, BufferSize, TimeOut);
  If pIPE.DataSize > 0 Then
    If String(pIPE.Options.OptionsData) = Msg Then
      Result := True;
  FreeMem(pRevData);
  FreeMem(pIPE);
end;destructor TPing.Destroy;
begin
  inherited Destroy;
  _INI_PING;
end;procedure TPing.CheckPing;
Var
  ConnectTT: Boolean;
begin
  ConnectTT := Ping(hCSocket.Address, 'Test Connect CDXX', 4000);
  If ConnectTT Then
  Begin
    If Not hCSocket.Active Then //如果没连通
      hCSocket.Active := True;  //连通
  End Else Begin
    PlaySound(Nil, 0, SND_PURGE);
    PlaySound(PChar('s3.wav'), 0, SND_ASYNC or SND_FILENAME);
    If hCSocket.Active Then
      hCSocket.Active := False;
  End;
end;end.

Answer 2

这是一段的ping 功能的程序,修改一下就可以用了!