DelphiでPing送信

DelphiでPing送信するアプリケーションを作成します。

画面設計

Delphiを起動し、ファイル⇒新規作成⇒Windows VCL アプリケーションをクリックします。
フォームに TButton×１個、TMemo×1個をドラッグ＆ドロップして配置します。
ファイル⇒すべて保尊をクリックしてプロジェクトフォルダを作成して、ユニットとプロジェクトを保存します。

IcmpApi.pas ユニットの作成

ファイル⇒新規作成⇒ユニット - Delphi を選択して新しいユニットを作成し、以下ソースコードをコピー＆ペーストします。ファイル⇒名前を付けて保存をクリックしてファイル名「IcmpApi.pas」で保存します。

unit IcmpApi;

interface

uses
  WinApi.Windows, System.SysUtils, WinApi.Winsock;

type

  TPingResult = record
    Address: string;        // 応答元 IP アドレス（文字列）
    Status: Cardinal;       // 成功/失敗コード
    RoundTripTime: Cardinal;// 応答時間 (ms)
    DataSize: Word;         // データサイズ
    Ttl: Byte;              // TTL
  end;

  IPAddr = ULONG;

  IP_OPTION_INFORMATION = record
    Ttl: UCHAR;
    Tos: UCHAR;
    Flags: UCHAR;
    OptionsSize: UCHAR;
    OptionsData: PUCHAR;
  end;
  PIP_OPTION_INFORMATION = ^IP_OPTION_INFORMATION;

  ICMP_ECHO_REPLY = record
    Address: IPAddr;                  // 応答元の IP アドレス
    Status: ULONG;                    // 成功/失敗コード
    RoundTripTime: ULONG;             // 応答までの時間 (ms)
    DataSize: WORD;                   // 返ってきたデータサイズ
    Reserved: WORD;                   // 予約領域
    Data: Pointer;                    // データへのポインタ
    Options: IP_OPTION_INFORMATION;   // IP オプション情報
  end;
  PICMP_ECHO_REPLY = ^ICMP_ECHO_REPLY;

  PIO_APC_ROUTINE = procedure(ApcContext: Pointer; IoStatusBlock: Pointer; Reserved: ULONG); stdcall;


function IcmpCreateFile: THandle; stdcall; external 'iphlpapi.dll';
function Icmp6CreateFile: THandle; stdcall; external 'iphlpapi.dll';
function IcmpCloseHandle(IcmpHandle: THandle): BOOL; stdcall; external 'iphlpapi.dll';
function IcmpSendEcho(
  IcmpHandle: THandle;
  DestinationAddress: IPAddr;
  RequestData: Pointer;
  RequestSize: WORD;
  RequestOptions: PIP_OPTION_INFORMATION;
  ReplyBuffer: Pointer;
  ReplySize: DWORD;
  Timeout: DWORD
): DWORD; stdcall; external 'iphlpapi.dll';
function IcmpParseReplies(
  ReplyBuffer: Pointer;
  ReplySize: DWORD
): DWORD; stdcall; external 'iphlpapi.dll';

function Ping(const Host:string; TimeoutMSec:Cardinal=3000;
  RequestSize:Word=32; DoNotFragment:Boolean=false):TPingResult;

const
  IP_SUCCESS                = 0;
  IP_BUF_TOO_SMALL          = 11001;  //応答バッファが小さすぎる
  IP_DEST_NET_UNREACHABLE   = 11002;  //宛先ネットワークに到達できない
  IP_DEST_HOST_UNREACHABLE  = 11003;  //宛先ホストに到達できない
  IP_DEST_PROT_UNREACHABLE  = 11004;  //宛先プロトコルに到達できない
  IP_DEST_PORT_UNREACHABLE  = 11005;  //宛先ポートに到達できない
  IP_NO_RESOURCES           = 11006;  //リソース不足
  IP_BAD_OPTION             = 11007;  //無効なオプション
  IP_HW_ERROR               = 11008;  //ハードウェアエラー
  IP_PACKET_TOO_BIG         = 11009;  //パケットが大きすぎる
  IP_REQ_TIMED_OUT          = 11010;  //応答がタイムアウト
  IP_BAD_REQ                = 11011;  //無効な要求
  IP_BAD_ROUTE              = 11012;  //無効なルート
  IP_TTL_EXPIRED_TRANSIT    = 11013;  //転送中に TTL が期限切れ
  IP_TTL_EXPIRED_REASSEM    = 11014;  //再構成中に TTL が期限切れ
  IP_PARAM_PROBLEM          = 11015;  //パラメータ問題
  IP_SOURCE_QUENCH          = 11016;  //ソースクエンチ（送信速度抑制）
  IP_OPTION_TOO_BIG         = 11017;  //オプションが大きすぎる
  IP_BAD_DESTINATION        = 11018;  //無効な宛先
  IP_UNKNOWN_ERROR          = Cardinal($FFFFFFFF);//勝手に定義

  IP_FLAG_DF = $02; // Don't Fragment
implementation


//PINGを送り応答を返します。
//  引数: 宛先ホスト名, タイムアウト時間(ミリ秒), リクエストデータサイズ(Byte), 非分割フラグ(DF)
//  戻値: TPingResult型
function Ping(const Host:string; TimeoutMSec:Cardinal=3000;
  RequestSize:Word=32; DoNotFragment:Boolean=false): TPingResult;
var
  WSAData: TWSAData;
  HostEnt: PHostEnt;
  IcmpHandle: THandle;
  Options: IP_OPTION_INFORMATION;
  Reply: PICMP_ECHO_REPLY;
  InAddr:TInAddr;
  RequestData:array of Byte;
  ReplyBuffer: array of Byte;
  ReturnValue:Cardinal;
  i:Integer;
  Bt:Byte;
begin
  ZeroMemory(@Result,SizeOf(Result));

  WSAStartup($202, WSAData);
  HostEnt := gethostbyname(PAnsiChar(AnsiString(Host)));
  WSACleanup();
  if HostEnt = nil then
  begin
    Result.Status:=IP_BAD_DESTINATION;
    Exit();
  end
  else
  begin
    InAddr.S_addr:=PInAddr(HOSTEnt.h_addr_list^).S_addr;
  end;

  if RequestSize=0 then RequestSize:=32;
  SetLength(RequestData,RequestSize);
  Bt:=$61;
  for i := Low(RequestData) to High(RequestData) do
  begin
    RequestData[i]:=Bt;
    inc(Bt);
    if Bt>$7a then Bt:=$61;
  end;
  SetLength(ReplyBuffer, SizeOf(ICMP_ECHO_REPLY)+RequestSize+256);

  IcmpHandle := IcmpCreateFile;
  if IcmpHandle = INVALID_HANDLE_VALUE then
  begin
    Result.Status:=IP_UNKNOWN_ERROR;
    Exit();
  end;

  ZeroMemory(@Options, SizeOf(Options));
  Options.Ttl := 64; // TTL
  if DoNotFragment then
    Options.Flags := IP_FLAG_DF;//DFフラグ設定

  ReturnValue:=IcmpSendEcho(
       IcmpHandle, InAddr.S_addr,
       @RequestData[0], RequestSize, @Options,
       @ReplyBuffer[0], Length(ReplyBuffer), TimeoutMSec
  );

  if ReturnValue>0 then
  begin
    Reply := PICMP_ECHO_REPLY(@ReplyBuffer[0]);
    InAddr.S_addr:=Reply.Address;
    Result.Address:=String(inet_ntoa(InAddr));
    Result.Status:=Reply.Status;
    Result.RoundTripTime:=Reply.RoundTripTime;
    Result.DataSize:=Reply.DataSize;
    Result.Ttl:=Reply.Options.Ttl;
  end
  else
    Result.Status:=IP_REQ_TIMED_OUT;
  IcmpCloseHandle(IcmpHandle);
end;


end.

ソースコードの記述

Unit1のフォームデザイナに切り替え、Button1をダブルクリックして以下ソースコードを入力します。
IcmpApi.pasファイルを同じプロジェクトフォルダに入れます。

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, IcmpApi;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}


procedure TForm1.Button1Click(Sender: TObject);
var Res:TPingResult; i:Integer;
begin
  res:=Ping('192.168.1.1'); //ここに任意のIPアドレスを指定する
  if res.Status=IP_SUCCESS then
  begin
    Memo1.Lines.Add(
      Format(
        '%s からの応答: バイト数=%d 時間=%dms TTL=%d',
        [res.Address, res.DataSize, res.RoundTripTime, res.Ttl]
      )
    );
  end
  else
  begin
    Memo1.Lines.Add('エラー:'+IntToStr(res.Status));
  end;
end;

end.

実行する

実行ボタンをクリックすると、コンパイルされ実行します。
Button1をクリックするとPingを送信し、返信結果がMemo1に表示されます。