Delphi XE5 で PING を使ってみる

Indy の IdIcmpClient.Ping() を使う場合は、exe を管理者権限で実行する必要があるようです。
ネット上に、Winsock を使ったサンプルがあったので、試してみました。
unit xpingUnit;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Winsock, Vcl.StdCtrls;
 
type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Button2: TButton;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
    runFlag : boolean;
  end;
 
var
  Form1: TForm1;
 
  // icmp.dll
  function IcmpCreateFile : THandle; stdcall; external 'icmp.dll';
  function IcmpCloseHandle (icmpHandle : THandle) : boolean; stdcall; external 'icmp.dll';
  function IcmpSendEcho (
    IcmpHandle : THandle;
    DestinationAddress : TInAddr;
    RequestData : Pointer; RequestSize : Smallint;
    RequestOptions : Pointer;
    ReplyBuffer : Pointer;
    ReplySize : DWORD;
    Timeout : DWORD) : DWORD; stdcall; external 'icmp.dll';
 
implementation
 
{$R *.dfm}
 
// -----------------------------------------------
// uses Winsock
// http://homepage1.nifty.com/MADIA/delphi/delphi_bbs/200607/200607_06070018.html
// 「同一LAN内のIPAdressやMacAdressを取得するには？」
// ほぼ、そのままのコードです。
// -----------------------------------------------
 
// IP アドレスからホスト名を得る
function GetHostName(Ip : AnsiString) : AnsiString;
var
  PH : PHostEnt;
  InAddr: TInAddr;
  WSADATA : TWSADATA;
begin
  Result := '';
  if Ip = '' then Exit;
  InAddr.S_addr := inet_addr(PAnsiChar(Ip));
  WSAStartup(MakeWord(1, 1) , WSADATA);  //MakeWord(1,1)=$0101
 
  PH := GetHostByAddr(@InAddr, 4, PF_INET);
 
  if PH = nil then Exit;
  Result := AnsiString(PH^.h_name);
  WSACleanup;
end;
 
// ホスト名から IP アドレスを得る
function GetIpAddress(HostName : AnsiString) : AnsiString;
var
  PH : PHostEnt;
  InAddr: TInAddr;
  WSADATA : TWSADATA;
begin
  Result := '';
  if HostName = '' then Exit;
  WSAStartup(MakeWord(1, 1), WSADATA);
 
  PH := GetHostByName(PAnsiChar(HostName));
 
  if PH = nil then Exit;
  InAddr := PInAddr(PH^.h_addr_list^)^;
  Result := inet_ntoa(InAddr);
  WSACleanup;
end;
// PING
function PingIP(Ip : Ansistring) : boolean;
var
  Hnd : THandle;
  InAddr : TInAddr;
  DW : DWORD;
  rep : array [1..128] of byte;
begin
  result := false;
  Hnd := IcmpCreateFile;
  if Hnd = INVALID_HANDLE_VALUE then Exit;
 
  InAddr.S_addr := inet_addr(PAnsiChar(Ip));
  DW := IcmpSendEcho(Hnd, InAddr, nil, 0, nil, @rep, 128, 500{Timeout});
  Result := DW <> 0;
  IcmpCloseHandle(Hnd);
end;
 
// 自PCのIPアドレスとPC名を取得
function LocalIP(var PcName: AnsiString): Ansistring;
type
  TaPInAddr = array [0..10] of PInAddr;
  PaPInAddr = ^TaPInAddr;
var
  PH : PHostEnt;
  pPtr: PaPInAddr;
  buffer: array [0..127] of AnsiChar;
  i: Integer;
  GInitData: TWSAData;
begin
  WSAStartup(MakeWord(1, 1), GInitData);
  Result := '';
  PcName := '';
 
  GetHostName(buffer);
 
  PH := GetHostByName(buffer);
  if PH = nil then Exit;
  PcName := AnsiString(PH^.h_name);
  pPtr := PaPInAddr(PH^.h_addr_list);
  i := 0;
  while pPtr^[i] <> nil do begin
    Result := inet_ntoa(pPtr^[i]^);
    Inc(i);
  end;
  WSACleanup;
end;
// 自PCのIPアドレスとPC名を得る
procedure TForm1.Button1Click(Sender: TObject);
var
  Ip : AnsiString;
  PcName : AnsiString;
begin
  Edit1.Text := '';
  Edit2.Text := '';
 
  Ip := LocalIP(PcName);
  if Ip <> '' then begin
    Edit1.Text := string(Ip);
    Edit2.Text := string(PcName);
  end;
end;
 
procedure TForm1.Button2Click(Sender: TObject);
var
  i : integer;
  n : integer;
  IpHead : Ansistring;
  Ip : Ansistring;
begin
  if Button2.Caption = 'PING' then begin
    runFlag := True;
    Button2.Caption := 'Break';
 
    Memo1.Lines.Clear;
    IpHead := '192.168.0.';
    n := LastDelimiter('.', Edit1.Text);
    if n > 0 then
      IpHead := AnsiString(Copy(String(Edit1.Text), 1, n));
 
    for i := 0 to 255 do begin
      if runFlag then begin
 
        Application.ProcessMessages;
 
        IP := IpHead + AnsiString(IntToStr(i));
        Label1.Caption := String(IP);
        Label1.Refresh;
 
        if PingIp(Ip) then
          Memo1.Lines.Add(String(Ip + AnsiString(StringOfChar(' ', 16 - Length(ip)))
             + GetHostName(Ip)));
      end
      else
        Break;
    end;
    if runFlag then
      Memo1.Lines.Add('---- term ----')
    else
      Memo1.Lines.Add('---- break ----');
  end
  else begin
    runFlag := False;
    Button2.Caption := 'PING';
    Application.ProcessMessages;
  end;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  Button1.Caption := 'LocalIP';
  Button2.Caption := 'PING';
  Edit1.Text := '';
  Edit2.Text := '';
  Label1.Caption := '';
  Memo1.Lines.Clear;
end;
 
end.