[Delphi] マシンの稼動状況を確認する死活監視(Ping)

マシンの死活監視に欠かせないのがPing。

くろねこも社内でアプリケーションサーバーがDBサーバーに接続しに行く前に死活監視を...と言う話を切り出してからはなかなか実現できず、問題だけが積み上がっていた。
だって、それに集中する時間が無いんだもん...

すでに、社内のマネージャからは「ライフワーク」といわれ始めた...

そんな状況を打開するために、ちょっと気合いを入れて調査してみる。

よくあるPingのサンプルプログラムでは管理者権限が必要。
管理者権限が不要といわれているプログラムをいくつか試してみたが動かず暗礁に乗り上げていたが...

本日、先日買ったノートPCで帰宅中に、最悪.net Frameworkでもいいか～と調べていると...
やっぱり、Pingクラスってあるんですね。
さらに、Pingクラスを使っている例が無いかググってみると、WMIで実行する方法がある。
WMIはWin32でも実行できるので、今回はこちらでコーディングしてみることにした。

できあがったソース。
なお、このプログラムのコンパイルにはタイプライブラリの取り込みが必要です。
Microsoft WMI Scripting V1.2 Library を取り込み、作成されたユニットをプロジェクトと同じフォルダに置くことを前提に作成してある。
※取り込み方法：メニューの「コンポーネント｜コンポーネントのインポート」で、コンポーネントのインポートウィザードを表示し、次にタイプライブラリのインポートを選択し「次へ」、一覧からMicrosoft WMI Scripting V1.2 Library を選択し「次へ」、ユニットの作成を選択し「完了」ボタンをクリック。

program PingExec;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Variants,
  ComObj,
  ActiveX,
  WbemScripting_TLB in 'WbemScripting_TLB.pas';

type
// 参考
//  Win32_PingStatus = record
//    string  Address;
//    uint32  BufferSize = 32;
//    boolean NoFragmentation = FALSE;
//    uint32  PrimaryAddressResolutionStatus;
//    string  ProtocolAddress = "";
//    string  ProtocolAddressResolved = "";
//    uint32  RecordRoute = 0;
//    boolean ReplyInconsistency;
//    uint32  ReplySize;
//    boolean ResolveAddressNames = FALSE;
//    uint32  ResponseTime;
//    uint32  ResponseTimeToLive;
//    string  RouteRecord[];
//    string  RouteRecordResolved[];
//    String  SourceRoute = "";
//    uint32  SourceRouteType = 0;
//    uint32  StatusCode;
//    uint32  Timeout = 1000;
//    uint32  TimeStampRecord[];
//    string  TimeStampRecordAddress[];
//    string  TimeStampRecordAddressResolved[];
//    uint32  TimeStampRoute = 0;
//    uint32  TimeToLive = 80;
//    uint32  TypeofService = 0;
//  end;
  TPingResult = record
    BufferSize: cardinal;
    ProtocolAddress: string;
    ResponseTime: cardinal;
    ResponseTimeToLive: cardinal;
  end;

function SendPing(address: string; var pr: TPingResult): integer;
var
  Locator:  ISWbemLocator;
  Services: ISWbemServices;
  SObjSet:  ISWbemObjectSet;
  SObject:  ISWbemObject;
  Enum:     IEnumVariant;
  TempObj:  OleVariant;
  TempVal: Cardinal;
  Query: string;
begin
  Result := -1;

  if Failed(CoInitialize(nil)) then Exit;
  try
    Locator := CoSWbemLocator.Create;
    Services := Locator.ConnectServer('.', 'root\cimv2', '', '', '', '', 0, nil);
    Query := 'SELECT * FROM Win32_PingStatus WHERE address=' + QuotedStr(address);
    SObjSet := Services.ExecQuery(Query, 'WQL', wbemFlagReturnImmediately and wbemFlagForwardOnly , nil);
    TempVal := 0;
    Enum := (SObjSet._NewEnum) as IEnumVariant;
    if (Succeeded(Enum.Next(1, TempObj, TempVal)) and (TempVal > 0)) then
    begin
      try
        SObject := IUnknown(TempObj) as ISWBemObject;
        if (SObject <> nil) then
        begin
          if VarIsNull(SObject.Properties_.Item('StatusCode', 0).Get_Value) then exit;

          Result := (SObject.Properties_.Item('StatusCode', 0).Get_Value);

          if (Result = 0) then
          begin
            with SObject.Properties_ do
            begin
              pr.ProtocolAddress := VarToStr(Item('ProtocolAddress', 0).Get_Value);
              pr.BufferSize := StrToIntDef(VarToStr(Item('BufferSize', 0).Get_Value), 0);
              pr.ResponseTime := StrToIntDef(VarToStr(Item('ResponseTime', 0).Get_Value), 0);
              pr.ResponseTimeToLive := StrToIntDef(VarToStr(Item('ResponseTimeToLive', 0).Get_Value), 0);
            end;
          end;
        end;
      finally
        SObject := nil;
        VarClear(TempObj);
      end;
    end;
  finally
    Enum.Reset;
    SObjSet := nil;
    Services := nil;
    Locator := nil;
  end;
end;

(** Main **)
var
  pr: TPingResult;
begin
  if (SendPing(ParamStr(1), pr) = 0) then
  begin
    System.Writeln(Format('%s からの応答: バイト数 =%d 時間 =%dms TTL=%d', [
      pr.ProtocolAddress, pr.BufferSize, pr.ResponseTime, pr.ResponseTimeToLive]));
  end
  else
  begin
    System.Writeln(Format('%s からの応答: 宛先ホストに到達できません。', [ParamStr(1)]));
  end;
end.

RFC 791準拠.ちなみにパラメータはコンピュータ名でもIPアドレスでも実行可能。IPv6 and IPv4 Support in WMIということなのでIPアドレスはIPv4, IPv6 双方可能だと思われる。

■参考URI

記事カテゴリ

ユーザー機能