如何在不使用 Indy 组件的情况下在 Delphi 10.1 中 ping 一个 IP 地址？

Question

如何在不使用 Indy 组件的情况下在 Delphi 10.1 中 ping 一个 IP 地址（或按服务器名称）？TIdICMPClient 使用提升的权限工作，但我想以普通用户的身份进行。

Answer 1

其他答案缺少一些东西。

这是一个可以解决问题的完整单元：

unit Ping2;

interface

function PingHost(const HostName: AnsiString; TimeoutMS: cardinal = 500): boolean;

implementation

uses Windows, SysUtils, WinSock;

function IcmpCreateFile: THandle; stdcall; external 'iphlpapi.dll';
function IcmpCloseHandle(icmpHandle: THandle): boolean; stdcall;
  external 'iphlpapi.dll';
function IcmpSendEcho(icmpHandle: THandle; DestinationAddress: In_Addr;
  RequestData: Pointer; RequestSize: Smallint; RequestOptions: Pointer;
  ReplyBuffer: Pointer; ReplySize: DWORD; Timeout: DWORD): DWORD; stdcall;
  external 'iphlpapi.dll';

type
  TEchoReply = packed record
    Addr: In_Addr;
    Status: DWORD;
    RoundTripTime: DWORD;
  end;

  PEchoReply = ^TEchoReply;

var
  WSAData: TWSAData;

procedure Startup;
begin
  if WSAStartup($0101, WSAData) <> 0 then
    raise Exception.Create('WSAStartup');
end;

procedure Cleanup;
begin
  if WSACleanup <> 0 then
    raise Exception.Create('WSACleanup');
end;

function PingHost(const HostName: AnsiString;
  TimeoutMS: cardinal = 500): boolean;
const
  rSize = $400;
var
  e: PHostEnt;
  a: PInAddr;
  h: THandle;
  d: string;
  r: array [0 .. rSize - 1] of byte;
  i: cardinal;
begin
  Startup;
  e := gethostbyname(PAnsiChar(HostName));
  if e = nil then
    RaiseLastOSError;
  if e.h_addrtype = AF_INET then
    Pointer(a) := e.h_addr^
  else
    raise Exception.Create('Name doesn''t resolve to an IPv4 address');

  d := FormatDateTime('yyyymmddhhnnsszzz', Now);

  h := IcmpCreateFile;
  if h = INVALID_HANDLE_VALUE then
    RaiseLastOSError;
  try
    i := IcmpSendEcho(h, a^, PChar(d), Length(d), nil, @r[0], rSize, TimeoutMS);
    Result := (i <> 0) and (PEchoReply(@r[0]).Status = 0);
  finally
    IcmpCloseHandle(h);
  end;
  Cleanup;
end;

end.

您可以使用这样的点击事件调用它：

procedure TForm1.button1Click(Sender: TObject);
begin
  if PingHost('172.16.24.2') then
    ShowMessage('WORKED')
  else
    ShowMessage('FAILED');
end;

请记住在uses列表中添加“Ping2”单元。

Answer 2

使用 Windows API。

像这样的粗略翻译来自：https://msdn.microsoft.com/en-us/library/windows/desktop/aa366050
(v=vs.85).aspx 应该可以解决问题。

var
  ICMPFile: THandle;
  IpAddress: ULONG;
  SendData: array[0..31] of AnsiChar;
  ReplyBuffer: PICMP_ECHO_REPLY;
  ReplySize: DWORD;
  NumResponses: DWORD;
begin
  IpAddress:= inet_addr('127.0.0.1');
  SendData := 'Data Buffer';

  IcmpFile := IcmpCreateFile;
  if IcmpFile <> INVALID_HANDLE_VALUE then
    try
      ReplySize:= SizeOf(ICMP_ECHO_REPLY) + SizeOf(SendData);
      GetMem(ReplyBuffer, ReplySize);
      try
        NumResponses := IcmpSendEcho(IcmpFile, IPAddress, @SendData, SizeOf(SendData),
                      nil, ReplyBuffer, ReplySize, 1000);
        if (NumResponses <> 0) then begin
          Writeln(Format('Received %d icmp message responses', [NumResponses]));
          Writeln('Information from the first response:');
          Writeln(Format('Received from %s', [inet_ntoa(in_addr(ReplyBuffer.Address))]));
          Writeln(Format('Data: %s', [PAnsiChar(ReplyBuffer.Data)]));
          Writeln(Format('Status = %d', [ReplyBuffer.Status]));
          WriteLn(Format('Roundtrip time = %d milliseconds',[ReplyBuffer.RoundTripTime]));
        end else begin
          WriteLn('Call to IcmpSendEcho failed');
          WriteLn(Format('IcmpSendEcho returned error: %d', [GetLastError]));
        end;
      finally
        FreeMem(ReplyBuffer);
      end;
    finally
      IcmpCloseHandle(IcmpFile);
    end
  else begin
    Writeln('Unable to open handle');
    Writeln(Format('IcmpCreateFile returned error: %d', [GetLastError]));
  end;