Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2005年04月01日] [更新 2015年03月14日]　Delphi サンプルプログラム集
   
280_アプリの起動と終了を知る WH_CBT フック
動作確認等 Windows 7 U64(SP1) + Delphi XE(UP1) Pro
280_HookCBTActivate.zip　[1,863 KB]　2015年03月14日版 (EXE 同梱)



  • 2005年12月08日
  • 「アプリケーションの終了を知る」コードを追加
  • [起動を知る・起動阻止] のコードに追加せず．各動作のコードを見やすくするため別にした
  • クラス名とウィンドウタイトルの取得コードが適切でなかったのを修正しました
  • 2007年09月22日
  • DLL からの受信メッセージとしてユーザ定義 (WM_APP + XX) を使用するコードを追加
  • 2007年10月29日
  • コードをコピペして使用した場合に発生する[リストのインデックスが範囲を超えています)]に対する修正
  • 2009年07月27日
  • 他の CBT フックのサンプルと重複しないように MapFileName を変更
  • コールバックの戻り値 (Result) を CallNextHookEx にした
  • 2013年03月17日
  • [DLL 関係] CreateFileMapping の第 1 引数を High(NativeUInt) に変更 (64 ビット対応)
  • [DLL 関係] packed record を record に変更
  • [DLL 関係] Delphi XE3 Pro VCL-32, VCL-64 でも動作確認
  • Windows 7 U64(SP1) + Delphi XE Pro で動作確認
  • 2015年03月14日
  • UIPI (ユーザーインターフェイス特権の分離) 対応処理を追加
  • コード整備等



アプリケーションの起動と終了を知る


WH_CBT フックを使用して，ウィンドウの生成やアプリの起動，終了を検出するサンプルです．
検出したウィンドウのタイトルとクラス名を TListView に表示するだけです．

WH_CBT フックは，ウィンドウの生成などのイベントに応じてシステムから呼出されるもので，メッセージの変更も可能です．下表のようなイベントの処理が可能となっています．このフック関数は DLL 内に置かなければ機能しません．



表1
WH_CBT フックの nCode 値

HCBT_ACTIVATE ウィンドウがこれからアクティブになる
HCBT_CLCKSKIPPED システムのメッセージキューからマウスメッセージが削除された
HCBT_CREATEWND ウィンドウが作成された後，WM_CREATE，WM_NCCREATEを受取る前，およびウィンドウの最終的な位置とサイズが決定される前
HCBT_DESTROYWND ウィンドウがこれから破棄される
HCBT_KEYSKIPPED キーボードのメッセージキューから削除された
HCBT_MINMAX ウィンドウがこれから最大化または最小化される
HCBT_MOVESIZE ウィンドウがこれから移動またはサイズ変更される
HCBT_QS システムのメッセージキューからWS_QUEUESYNCメッセージが取出された
HCBT_SETFOCUS ウィンドウはこれから入力フォーカスを受取る
HCBT_SYSCOMMAND メッセージキューからシステムコマンドメッセージが取出された


下のコードは，本ページで使用している DLL のプロジェクトのソースコードです．最後のサンプルではメッセージ文字列の登録をしないので， GetHookMsgString がありません．

リスト1
サンプルプログラムで使用している DLL のプロジェクトのソース 
library plHookCBT;

uses
  plHookCBTUnit in 'plHookCBTUnit.pas';

//-----------------------------------------------------------------------------
//  外部からDLL内のメソッドを利用可能にするためのオマジナイ
//-----------------------------------------------------------------------------
exports
  StartCBTHook,
  StopCBTHook,
  GetHookMsgString;
end.



01_アプリケーションの起動を知る・起動阻止等


WH_CBT フックでウィンドウの生成等を検出します．それだけでは面白くないので，
  • エクセルの起動を阻止．つまりエクセルは起動させない
  • メモ帳は起動するが，位置とサイズは変更できない
    変更しようとしても，元の位置とサイズに戻す
という仕様にしてみました．この動作を実現するコードは DLL に記述しています．

このサンプルでは，DLL 内で定義してある文字列を，DLL を使うプログラム側で取得し，メッセージの値を生成していますが，RegisterWindowMessage 関数で取得した値を DLL 側に渡す方法もあります．


図1
設計時画面
  • 白いのは TListView
図2
プロジェクトのファイル構成
  • plHookCBT.dpr が DLL のプロジェクト

テストの実行例です．
このサンプルでは，64 ビットアプリケーションのメッセージは処理できません．つまり，64 ビットアプリケーションの起動や破棄等は検出できないことに注意してください．


図3
ワードとエクセルを起動
  • EXE を直接実行してテスト
  • エクセルは実際には起動しない
図4
メモ帳を起動してリサイズ
  • EXE を直接実行してテスト
  • 32 ビット版のメモ帳を起動
  • 位置とサイズは DLL 内の設定となる
  • 位置もサイズも変更できない
  • 変更しようとしても元に戻される

このサンプルではエクセルの起動を阻止しています．
このサンプルの終了後にエクセルを起動すると，下図のように，「Excel は前回正常に起動しませんでした」というダイアログが表示されます．
この場合，特にセーフモードで起動する必要はありません．


図5
エクセルの再起動

リスト2
アプリケーションの起動を知る・起動阻止等 
unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
 StdCtrls, ComCtrls;

type
 TForm1 = class(TForm)
   Button1: TButton;
   Button2: TButton;
   ListView1: TListView;
   procedure FormCreate(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
   procedure Button1Click(Sender: TObject);
   procedure Button2Click(Sender: TObject);
 protected
   procedure WndProc(var msg: TMessage);override;
   procedure DisplayWindowInfo(ClassName, TitleStr: String);
   function GetWindowTitleStr(hWindow: HWND): String;
   function GetWindowClassNameStr(hWindow: HWND):string;
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.DFM}

function StartCBTHook(Wnd: HWND): Boolean; stdcall; external 'PLHOOKCBT.DLL';
procedure StopCBTHook; stdcall; external 'PLHOOKCBT.DLL';
function  GetHookMsgString: PChar; stdcall; external 'PLHOOKCBT.DLL';

var
  hHookLib    : THANDLE;
  HookMessage : String;
  MsgHooking  : WORD;


//=============================================================================
//  フォーム生成時の処理
//  クラス名とタイトルを一覧表示するためのListViewの設定
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LStyle : Integer;
begin
  ListView1.ViewStyle := vsReport;

  ListView1.Columns.Add;
  ListView1.Columns[0].Caption := ' CLASS';
  ListView1.Columns[0].Width   := 130;
  ListView1.Columns.Add;
  ListView1.Columns[1].Caption := ' TITLE';
  ListView1.Columns[1].Width   := 151;

  //垂直スクロールバーを最初から表示
  LStyle := GetWindowLong(ListView1.Handle, GWL_STYLE);
  ShowScrollBar(ListView1.Handle, SB_VERT, True);
  SetWindowLong(ListView1.Handle, GWL_STYLE, LStyle);
end;

//=============================================================================
//  フォーム破棄時の処理
//  フックを解除
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  if hHookLib <> 0 then begin
    StopCBTHook;
    FreeLibrary(hHookLib);
  end;
end;

//=============================================================================
//  [StartHook]ボタン
//  フックを有効にする
//  予めDLL内で定義してある文字列を使用してフックメッセージを登録
//  UIPI(ユーザーインターフェイス特権の分離)対応処理
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
const
  MSGFLT_ADD    = 1;
  MSGFLT_REMOVE = 2;
var
  DLLHandle  : THandle;
  FuncFilter : function (msg: Cardinal; dwFlag: DWORD): BOOL; stdcall;
begin
  if hHookLib = 0 then begin
    hHookLib := LoadLibrary('PLHOOKCBT.DLL');
    StartCBTHook(Handle);
    HookMessage := GetHookMsgString;
    MsgHooking  := RegisterWindowMessage(PChar(HookMessage));

    //UIPI(ユーザーインターフェイス特権の分離)対応処理
    //このプログラムを管理者権限で実行してもメッセージの受信を可能にする
    if CheckWin32Version(6, 0) then begin
      DLLHandle := loadLibrary('user32.dll');
      try
        if DLLHandle > 0 then begin
          @FuncFilter := GetProcAddress(DLLHandle, 'ChangeWindowMessageFilter');
          if @FuncFilter <> nil then begin
            FuncFilter(MsgHooking, MSGFLT_ADD);
          end;
        end;
      finally
        FreeLibrary(DLLHandle);
      end;
    end;
  end;
end;

//=============================================================================
//  [StopHook]ボタン
//  フックを無効にする
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  FormDestroy(nil);
end;

//=============================================================================
//  DLLからのメッセージを受取る
//  ここではフォームのWndProcメソッドを使用
//=============================================================================
procedure TForm1.WndProc(var msg: TMessage);
var
  TargetWnd : HWND;
begin
  inherited WndProc(msg);

  if msg.Msg = MsgHooking then begin
    TargetWnd := msg.WParam;
    //クラス名とウィンドウタイトルをListViewに表示
    DisplayWindowInfo(GetWindowClassNameStr(TargetWnd),
                      GetWindowTitleStr(TargetWnd));
  end;
end;

//=============================================================================
//  ListViewに起動したアプリのクラス名とタイトルを表示
//=============================================================================
procedure TForm1.DisplayWindowInfo(ClassName, TitleStr: String);
var
  LItem : TListItem;
begin
  if Trim(ClassName) = '' then exit;

  LItem := ListView1.Items.Add;
  LItem.Caption := ClassName;
  LItem.SubItems.Add(TitleStr);


  //ListViewの一番最後を表示
  //ここでは実際にはMakeVisibleだけでOK
  ListView1.Items[ListView1.Items.Count - 1].Selected := True;
  ListView1.Items[ListView1.Items.Count - 1].Focused  := True;
  ListView1.Items[ListView1.Items.Count - 1].MakeVisible(True);
end;

//-----------------------------------------------------------------------------
//  ウィンドウハンドルからウィンドウのクラス名を取得
//-----------------------------------------------------------------------------
function TForm1.GetWindowClassNameStr(hWindow: HWND): string;
var
  Buffer : array[0..MAX_PATH-1] of Char;
  Len    : Integer;
begin
  FillChar(Buffer, SizeOf(Buffer), #0);
  Len := GetClassName(hWindow, Buffer, Length(Buffer));
  if Len > 0 then Result := Buffer else Result := '';
end;

//-----------------------------------------------------------------------------
//  ウィンドウハンドルからウィンドウのタイトルを取得
//-----------------------------------------------------------------------------
function TForm1.GetWindowTitleStr(hWindow: HWND): String;
var
  Buffer : array[0..MAX_PATH-1] of Char;
  Len    : Integer;
begin
  FillChar(Buffer, SizeOf(Buffer), #0);
  Len := GetWindowText(hWindow, Buffer, Length(Buffer));
  if Len > 0 then Result := Buffer else Result := '';
end;

end.


DLL のコードです．
Delphi XE2, Delphi XE3 でターゲットプラットフォームを Win64 にすれば，64 ビット版のアプリのウィンドウの生成の検出が可能となります．当然，DLL を利用するプログラムも 64 ビットにする必要があります．
32 ビットプロセスでは 64 ビット DLL を読み込んで実行することができません．また、64 ビットプロセスでは 32 ビット DLL を読み込んで実行することができません．
DLL Injection という機能を使用する方法があるようですが，筆者はテストしていません．


リスト3
サンプルプログラムで使用している DLL のコード		 
unit plHookCBTUnit;

interface

uses
  Windows, Messages, SysUtils;

//外部のアプリケーションから使用する関数類
function StartCBTHook(Wnd: HWND): Boolean; stdcall;
procedure StopCBTHook; stdcall;
function  GetHookMsgString: PChar; stdcall;

implementation

//共有メモリの内容の構造体
type
  PHookInfo = ^THookInfo;
  THookInfo = record
  HookHandle : HHOOK;
  HostWnd    : HWND;
  MsgID      : WORD;
end;

// hMapFile    : メモリマップドファイルのハンドル
// HookStr     : Hostへの通知メッセージ定義に使用
// MapFileName : メモリマップドファイル名
var
  hMapFile : THandle;

const
  HookStr     = 'plHookCBT hook';
  MapFileName = 'HookCBTActivate';

//-----------------------------------------------------------------------------
//  ウィンドウハンドルからウィンドウクラス名を取得
//-----------------------------------------------------------------------------
function GetClassNameStr(hWindow: HWND): string;
var
  Buffer : array[0..MAX_PATH-1] of Char;
  Len    : Integer;
begin
  FillChar(Buffer, SizeOf(Buffer), #0);
  Len := GetClassName(hWindow, Buffer, Length(Buffer));
  if Len > 0 then Result := Buffer else Result := '';
end;

//-----------------------------------------------------------------------------
//  ウィンドウハンドルからウィンドウのタイトルを取得
//-----------------------------------------------------------------------------
function GetWindowTitleStr(hWindow: HWND): String;
var
  Buffer : array[0..MAX_PATH - 1] of Char;
  Len    : Integer;
begin
  FillChar(Buffer, SizeOf(Buffer), #0);
  Len := GetWindowText(hWindow, Buffer, Length(Buffer));
  if Len > 0 then Result := Buffer else Result := '';
end;

//-----------------------------------------------------------------------------
//  メッセージ作成用文字列の取得関数
//-----------------------------------------------------------------------------
function GetHookMsgString: PChar; stdcall;
begin
  Result := HookStr;
end;

//-----------------------------------------------------------------------------
//  共有メモリアクセスのための準備
//
//  成功すると0を返す.失敗すると負数を返す.
//  負の値で処理を分岐できるようになっているが,このコードでは未使用.
//-----------------------------------------------------------------------------
function MapFileMemory(var AMapWnd: THandle; var ApMap: Pointer): Integer;
begin
  Result := 0;

  //メモリマップドファイルを開く
  AMapWnd := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MapFileName));
  if AMapWnd = 0 then begin
    Result := -1;
  end else begin
    //メモリマップドファイルの割り当て
    ApMap := MapViewOfFile(AMapWnd, FILE_MAP_ALL_ACCESS, 0, 0, 0);
    if ApMap = nil then begin
      Result := -2;
      CloseHandle(AMapWnd);
    end;
  end;
end;

//-----------------------------------------------------------------------------
//  共有メモリアクセスの後始末
//  割当てたメモリがあればビューを解除
//  ハンドルがあればクローズ
//-----------------------------------------------------------------------------
procedure UnMapFileMemory(AMapWnd: THandle; ApMap: Pointer);
begin
  if ApMap <> nil then UnmapViewOfFile(ApMap);
  if AMapWnd <> 0 then CloseHandle(AMapWnd);
end;

//-----------------------------------------------------------------------------
//  フックのコールバック関数
//  メッセージIDはこのDLL内で設定した文字列から生成したもの
//-----------------------------------------------------------------------------
function MyHookProc(nCode: Integer; wPar: WPARAM; lPar: LPARAM): LRESULT; stdcall;
var
  LpMap      : Pointer;
  LMapWnd    : THandle;
  LTargetWnd : HWND;
  LClass     : String;
  LFlag      : UINT;
begin
  Result := 0;
  if MapFileMemory(LMapWnd, LpMap) <> 0 then exit;

  if nCode < 0 then begin
    Result := CallNextHookEx(pHookInfo(LpMap)^.HookHandle, nCode, wPar, lPar);
  end else begin
    //操作対象のウィンドウハンドルとクラス名取得
    LTargetWnd := wPar;
    LClass     := GetClassNameStr(LTargetWnd);
    case nCode of
      HCBT_ACTIVATE:
      begin
        //StartCBTHookの引数で指定したウィンドウにメッセージを送信
        PostMessage(pHookInfo(LpMap)^.HostWnd, pHookInfo(LpMap)^.MsgID, wPar, lPar);

        //エクセルの場合
        if Pos('Excel', GetWindowTitleStr(LTargetWnd) ) > 0 then begin
          Result := 1;
          SendMessage(LTargetWnd, WM_CLOSE, 0, 0);
        end;
        //メモ帳の表示位置とサイズを強制設定
        if LClass = 'Notepad' then begin
          LFlag := SWP_NOZORDER or SWP_SHOWWINDOW;
          SetWindowPos(LTargetWnd, 0, 0, 0, 500, 600, LFlag);
        end;
      end;

      HCBT_CREATEWND:
      begin
        //クラス名がXLMAINのウィンドウは生成させない
        if LClass = 'XLMAIN' then Result := 1;
      end;

      HCBT_MOVESIZE:
      begin
        //メモ帳は移動リサイズさせない
        if LClass = 'Notepad' then Result := 1;
      end;

      HCBT_MINMAX:
      begin
        //メモ帳は最大化も最小化もさせない
        if LClass = 'Notepad' then Result := 1;
      end;
    end;

    if Result <> 1 then begin
      Result := CallNextHookEx(pHookInfo(LpMap)^.HookHandle, nCode, wPar, lPar);
    end;
  end;

  UnMapFileMemory(LMapWnd, LpMap);
end;

//-----------------------------------------------------------------------------
//  フック関数の登録
//  登録するフック関数はMyHookProc
//-----------------------------------------------------------------------------
function StartCBTHook(Wnd: HWND): Boolean; stdcall;
var
  LMapWnd : THandle;
  LpMap   : Pointer;
begin
  Result := False;
  //メモリマップドファイル使用準備
  MapFileMemory(LMapWnd, LpMap);

  if LpMap <> nil then begin
    //DLL内部で使用する変数類を共有メモリにセット
    //ここでは引数のホスト側のウィンドウハンドルのみ
    pHookInfo(LpMap)^.HostWnd := Wnd;
    //フックをインストール}
    pHookInfo(LpMap)^.HookHandle := SetWindowsHookEx(WH_CBT,
                                                     @MyHookProc,
                                                     hInstance,
                                                     0);
    //アプリケーションへ通知するメッセージを登録
    pHookInfo(LpMap)^.MsgID := RegisterWindowMessage(HookStr);
    if pHookInfo(LpMap)^.MsgID = 0 then exit;

    //フック成功
    Result := pHookInfo(LpMap)^.HookHandle > 0;
    //メモリマップドファイル使用終了処理
    UnMapFileMemory(LMapWnd, LpMap);
  end;
end;

//-----------------------------------------------------------------------------
//  フックの解除
//-----------------------------------------------------------------------------
procedure StopCBTHook; stdcall;
var
  LMapWnd : THandle;
  LpMap   : Pointer;
begin
  //メモリマップドファイル使用準備
  MapFileMemory(LMapWnd, LpMap);

  if LpMap <> nil then begin
    //フック解除
    if pHookInfo(LpMap)^.HookHandle > 0 then begin
      UnhookWindowsHookEx(pHookInfo(LpMap)^.HookHandle);
    end;
    //メモリマップドファイル使用終了処理
    UnMapFileMemory(LMapWnd, LpMap);
  end;
end;

//-----------------------------------------------------------------------------
//  ユニット初期化部
//  メモリマップドファイルの作成
//
//  High(NativeUInt)の値は
//  32ビットアプリでは$FFFFFFFF
//  64ヒットアプリでは$FFFFFFFFFFFFFFFF
//-----------------------------------------------------------------------------
initialization
begin
  hMapFile := CreateFileMapping(High(NativeUInt),
                                nil,
                                PAGE_READWRITE,
                                0,
                                SizeOf(THookInfo),
                                PChar(MapFileName));
end;

//-----------------------------------------------------------------------------
//  ユニット終了処理部
//  メモリマップドファイルのクローズ
//-----------------------------------------------------------------------------
finalization
begin
  if hMapFile <> 0 then CloseHandle(hMapFile);
end;

end.



02_アプリケーションの終了を知る


WH_CBT フックの HCBT_DESTROYWND を検出します．つまり，アプリケーションの終了の検出です．
このサンプルのコードは，上のサンプルとほとんど同じです．違うのは DLL の名前だけです．
自分自身のアプリで，CreateProcess や ShellExecuteEx で他のアプリを起動した場合は，グローバルフックを使用しなくても，その終了を知ることができます．

このサンプルでは，DLL 内で定義してある文字列を，DLL を使うプログラム側で取得し，メッセージの値を生成していますが，RegisterWindowMessage 関数で取得した値を DLL 側に渡す方法もあります．


図6
設計時画面
図7
エクセルを終了した結果
  • エクセルを起動
  • [Start Hook] をクリック
  • エクセルを閉じる
  • エクセルも GDI+ を使用している

リスト4
アプリケーション終了メッセージ取得用サンプルプログラムのコード 
unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
 StdCtrls, ComCtrls;

type
 TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    ListView1: TListView;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
 protected
   procedure WndProc(var msg: TMessage);override;
   procedure DisplayWindowInfo(ClassName, TitleStr: String);
   function GetWindowTitleStr(hWindow: HWND): String;
   function GetWindowClassNameStr(hWindow: HWND):string;
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.DFM}

function StartCBTHook(Wnd: HWND): Boolean; stdcall; external 'plHookCBTDestroy.dll';
procedure StopCBTHook; stdcall; external 'plHookCBTDestroy.dll';
function  GetHookMsgString: PChar; stdcall; external 'plHookCBTDestroy.dll';

var
  hHookLib    : THANDLE;
  HookMessage : String;
  MsgHooking  : WORD;


//=============================================================================
//  フォーム生成時の処理
//  クラス名とタイトルを一覧表示するためのListViewの設定
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
   LStyle : Integer;
begin
  ListView1.ViewStyle := vsReport;

  ListView1.Columns.Add;
  ListView1.Columns[0].Caption := ' CLASS';
  ListView1.Columns[0].Width   := 130;
  ListView1.Columns.Add;
  ListView1.Columns[1].Caption := ' TITLE';
  ListView1.Columns[1].Width   := 151;

  //垂直スクロールバーを最初から表示
  LStyle := GetWindowLong(ListView1.Handle, GWL_STYLE);

  ShowScrollBar(ListView1.Handle, SB_VERT, True);
  SetWindowLong(ListView1.Handle, GWL_STYLE, LStyle);
end;

//=============================================================================
//  フォーム破棄時の処理
//  フックを解除
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  if hHookLib <> 0 then begin
    StopCBTHook;
    FreeLibrary(hHookLib);
  end;
end;

//=============================================================================
//  [StartHook]ボタン
//  フックを有効にする
//  予めDLL内で定義してある文字列を使用してフックメッセージを登録
//  UIPI(ユーザーインターフェイス特権の分離)対応処理
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
const
  MSGFLT_ADD    = 1;
  MSGFLT_REMOVE = 2;
var
  DLLHandle  : THandle;
  FuncFilter : function (msg: Cardinal; dwFlag: DWORD): BOOL; stdcall;
begin
  if hHookLib = 0 then begin
    hHookLib := LoadLibrary('PLHOOKCBT.DLL');
    StartCBTHook(Handle);
    HookMessage := GetHookMsgString;
    MsgHooking  := RegisterWindowMessage(PChar(HookMessage));

    //UIPI(ユーザーインターフェイス特権の分離)対応処理
    //このプログラムを管理者権限で実行してもメッセージの受信を可能にする
    if CheckWin32Version(6, 0) then begin
      DLLHandle := loadLibrary('user32.dll');
      try
        if DLLHandle > 0 then begin
          @FuncFilter := GetProcAddress(DLLHandle, 'ChangeWindowMessageFilter');
          if @FuncFilter <> nil then begin
            FuncFilter(MsgHooking, MSGFLT_ADD);
          end;
        end;
      finally
        FreeLibrary(DLLHandle);
      end;
    end;
  end;
end;

//=============================================================================
//  フックを無効にする
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  FormDestroy(nil);
end;

//=============================================================================
//  Application側でメッセージ通知を受取る
//  ここではフォームのWndProcメソッドを使用
//=============================================================================
procedure TForm1.WndProc(var msg: TMessage);
var
  TargetWnd : HWND;
begin
  inherited WndProc(msg);

  //plHookCBTDestroy.dllから来たメッセージの場合
  if msg.Msg = MsgHooking then begin
    TargetWnd := msg.WParam;
    //クラス名とウィンドウタイトルをListViewに表示
    DisplayWindowInfo(GetWindowClassNameStr(TargetWnd),
                      GetWindowTitleStr(TargetWnd));
  end;
end;

//-----------------------------------------------------------------------------
//  ListViewにウィンドウのクラス名とタイトルを表示
//-----------------------------------------------------------------------------
procedure TForm1.DisplayWindowInfo(ClassName, TitleStr: String);
var
  LItem : TListItem;
begin
  if Trim(ClassName) = '' then exit;

  LItem := ListView1.Items.Add;
  LItem.Caption := ClassName;
  LItem.SubItems.Add(TitleStr);

  //ListViewの一番最後を表示
  //ここでは実際にはMakeVisibleだけでOK
  ListView1.Items[ListView1.Items.Count - 1].Selected := True;
  ListView1.Items[ListView1.Items.Count - 1].Focused  := True;
  ListView1.Items[ListView1.Items.Count - 1].MakeVisible(True);
end;

//-----------------------------------------------------------------------------
//  ウィンドウハンドルからウィンドウのクラス名を取得
//-----------------------------------------------------------------------------
function TForm1.GetWindowClassNameStr(hWindow: HWND): string;
var
  Buffer : array[0..MAX_PATH-1] of Char;
  Len    : Integer;
begin
  FillChar(Buffer, SizeOf(Buffer), #0);
  Len := GetClassName(hWindow, Buffer, Length(Buffer));
  if Len > 0 then Result := Buffer else Result := '';
end;

//-----------------------------------------------------------------------------
//  ウィンドウハンドルからウィンドウのタイトルを取得
//-----------------------------------------------------------------------------
function TForm1.GetWindowTitleStr(hWindow: HWND): String;
var
  Buffer : array[0..MAX_PATH-1] of Char;
  Len    : Integer;
begin
  FillChar(Buffer, SizeOf(Buffer), #0);
  Len := GetWindowText(hWindow, Buffer, Length(Buffer));
  if Len > 0 then Result := Buffer else Result := '';
end;

end.


DLL のコードも上のサンプルとほとんど同じです．
違うのは DLL の名前と，以下のフックのコールバック関数の処理部分です．


リスト5
DLL 内のフックのコールバック関数のコード		 
//-----------------------------------------------------------------------------
//  フックのコールバック関数
//-----------------------------------------------------------------------------
function MyHookProc(nCode: Integer; wPar: WPARAM; lPar: LPARAM): LRESULT; stdcall;
var
  LMapWnd : THandle;
  LpMap   : Pointer;
begin
  Result := 0;
  if MapFileMemory(LMapWnd, LpMap) <> 0 then exit;

  if nCode < 0 then begin
    Result := CallNextHookEx(pHookInfo(LpMap)^.HookHandle, nCode, wPar, lPar);
  end else begin
    case nCode of
　　  HCBT_DESTROYWND:
      begin
        PostMessage(pHookInfo(LpMap)^.HostWnd, pHookInfo(LpMap)^.MsgID, wPar, lPar);
      end;
    end;
    Result := CallNextHookEx(pHookInfo(LpMap)^.HookHandle, nCode, wPar, lPar);
  end;

  UnMapFileMemory(LMapWnd, LpMap);
end;



03_ユーザ定義メッセージ WM_APP を使用する


ここまでのサンプルでは，メッセージの設定に RegisterWindowMessage 関数を使用しています．
この関数を使用すると，システムで一意のメッセージの数値を動的に決定してくれます．したがって本来はこの RegisterWindowMessage を使用すべきですが，WM_APP + XXX という静的な数値を直接使用することもできます．そのサンプルです．
WH_CBT フックの HCBT_ACTIVATE を検出し，アプリケーションの起動時にメッセージを送信します．

このサンプルのコードは，上のサンプルとほとんど同じです．違うのは DLL の名前と，メッセージ登録用の RegisterWindowMessage 関係を使用していないことだけです．



図8
設計時画面
図9
アプリを起動
  • 32 ビット版のメモ帳を起動
  • 32 ビット版のエクセルを起動
  • 32 ビット版のワードを起動
  • サンプルのフォームをクリック

リスト6
静的なメッセージの値を使用して，アクティブになったウィンドウを検出 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls;

type
 TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    ListView1: TListView;
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
 protected
   procedure DisplayWindowInfo(ClassName, TitleStr: String);
   function GetWindowTitleStr(hWindow: HWND): String;
   function GetWindowClassNameStr(hWindow: HWND):string;
 private
   { Private declarations }
   hHookLib  : THANDLE;
   procedure WMAppMessage(var Msg: TMessage); message WM_APP + 1;
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.DFM}

// DLL内の呼出関数類
function StartCBTHook(Wnd: HWND): Boolean; stdcall; external 'PLHOOKCBTMSG.DLL';
procedure StopCBTHook; stdcall; external 'PLHOOKCBTMSG.DLL';


//=============================================================================
//  フォーム生成時の処理
//  クラス名とタイトルを一覧表示するためのListViewの設定
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
var
  LStyle : Integer;
begin
  ListView1.ViewStyle := vsReport;

  ListView1.Columns.Add;
  ListView1.Columns[0].Caption := ' CLASS';
  ListView1.Columns[0].Width   := 130;
  ListView1.Columns.Add;
  ListView1.Columns[1].Caption := ' TITLE';
  ListView1.Columns[1].Width   := 151;

  //垂直スクロールバーを最初から表示
  LStyle := GetWindowLong(ListView1.Handle, GWL_STYLE);
  ShowScrollBar(ListView1.Handle, SB_VERT, True);
  SetWindowLong(ListView1.Handle, GWL_STYLE, LStyle);
end;

//=============================================================================
//  フォーム破棄時の処理
//  フックを解除
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
  if hHookLib <> 0 then begin
    StopCBTHook;
    FreeLibrary(hHookLib);
  end;
end;

//=============================================================================
//  [StartHook]ボタン
//  フックを有効にする
//  UIPI(ユーザーインターフェイス特権の分離)対応処理
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
const
  MSGFLT_ADD    = 1;
  MSGFLT_REMOVE = 2;
var
  DLLHandle  : THandle;
  FuncFilter : function (msg: Cardinal; dwFlag: DWORD): BOOL; stdcall;
begin
  if hHookLib = 0 then begin
    hHookLib := LoadLibrary('PLKHOOKCBTMSG.DLL');
    StartCBTHook(Handle);

    //UIPI(ユーザーインターフェイス特権の分離)対応処理
    //このプログラムを管理者権限で実行してもメッセージの受信を可能にする
    if CheckWin32Version(6, 0) then begin
      DLLHandle := loadLibrary('user32.dll');
      try
        if DLLHandle > 0 then begin
          @FuncFilter := GetProcAddress(DLLHandle, 'ChangeWindowMessageFilter');
          if @FuncFilter <> nil then begin
            FuncFilter(WM_APP + 1, MSGFLT_ADD);
          end;
        end;
      finally
        FreeLibrary(DLLHandle);
      end;
    end;
  end;
end;

//=============================================================================
//  [StopHook]ボタン
//  フックを無効にする
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
  FormDestroy(nil);
end;

//=============================================================================
//  Application側でメッセージ通知を受取る
//  ここでは定義したWM_APP+1メッセージ受信専用のプロシージャーを作成
//=============================================================================
procedure TForm1.WMAppMessage(var Msg: TMessage);
var
  TargetWnd : HWND;
begin
  TargetWnd := msg.WParam;
  //クラス名とウィンドウタイトルをListViewに表示
  DisplayWindowInfo(GetWindowClassNameStr(TargetWnd),
                    GetWindowTitleStr(TargetWnd));
end;

//=============================================================================
//  ListViewにウィンドウのクラス名とタイトルを表示
//=============================================================================
procedure TForm1.DisplayWindowInfo(ClassName, TitleStr: String);
var
  LItem : TListItem;
begin
  if Trim(ClassName) = '' then exit;

  LItem := ListView1.Items.Add;
  LItem.Caption := ClassName;
  LItem.SubItems.Add(TitleStr);

  //ListViewの一番最後を表示
  //ここでは実際にはMakeVisibleだけでOK
  ListView1.Items[ListView1.Items.Count - 1].Selected := True;
  ListView1.Items[ListView1.Items.Count - 1].Focused  := True;
  ListView1.Items[ListView1.Items.Count - 1].MakeVisible(True);
end;

//-----------------------------------------------------------------------------
//  ウィンドウハンドルからウィンドウのクラス名を取得
//-----------------------------------------------------------------------------
function TForm1.GetWindowClassNameStr(hWindow: HWND): string;
var
  Buffer : array[0..MAX_PATH-1] of Char;
  Len    : Integer;
begin
  FillChar(Buffer, SizeOf(Buffer), #0);
  Len := GetClassName(hWindow, Buffer, Length(Buffer));
  if Len > 0 then Result := Buffer else Result := '';
end;

//-----------------------------------------------------------------------------
//  ウィンドウハンドルからウィンドウのタイトルを取得
//-----------------------------------------------------------------------------
function TForm1.GetWindowTitleStr(hWindow: HWND): String;
var
  Buffer : array[0..MAX_PATH-1] of Char;
  Len    : Integer;
begin
  FillChar(Buffer, SizeOf(Buffer), #0);
  Len := GetWindowText(hWindow, Buffer, Length(Buffer));
  if Len > 0 then Result := Buffer else Result := '';
end;

end.


DLL のコードも上のサンプルとほとんど同じです．
違いは DLL の名前，メッセージ関係のコードと，以下のコールバック関数の処理部分です．


リスト7
DLL 内のフックのコールバック関数部分		 
//-----------------------------------------------------------------------------
//  フックのコールバック関数
//   HCBT_ACTIVATEの時にWM_APP + 1を送信する
//-----------------------------------------------------------------------------
function MyHookProc(nCode: Integer; wPar: WPARAM; lPar: LPARAM): LRESULT; stdcall;
var
  LMapWnd : THandle;
  LpMap   : Pointer;
begin
  Result := 0;
  if MapFileMemory(LMapWnd, LpMap) <> 0 then exit;

  if nCode < 0 then begin
    Result := CallNextHookEx(pHookInfo(LpMap)^.HookHandle, nCode, wPar, lPar);
  end else begin
    if nCode = HCBT_ACTIVATE then begin
      PostMessage(pHookInfo(LpMap)^.HostWnd, WM_APP + 1, wPar, lPar);
    end;
    Result := CallNextHookEx(pHookInfo(LpMap)^.HookHandle, nCode, wPar, lPar);
  end;

  UnMapFileMemory(LMapWnd, LpMap);
end;