|
Delphi Programming / Object Pascal
[掲載 2007年09月23日] [更新 2015年03月11日] Delphi サンプルプログラム集 |
290_グローバルフック WH_GETMESSAGE |
動作確認等 |
Windows 7 U64(SP1) + Delphi XE(UP1) Pro |
|
290_HookGetMessage.zip [1,216 KB] 2015年03月11日版 (EXE 同梱) |
- 2007年10月29日
- コードをコピペして使用した場合に発生する [リストのインデックスが範囲を超えています] に対する修正
- 2009年02月28日
- [メッセージを選択してテスト] を追加
- 2009年07月27日
- 他のフックのサンプルと重複しないように MapFileName を変更
- コールバックの戻り値 (Result) を CallNextHookEx にした
- 2015年03月11日
- WM_USER を WM_APP に変更
- Windows 7 + Delphi XE で動作可能なコードに修正
- UIPI (ユーザーインターフェイス特権の分離) 対応コードを追加
- コード整備
|
01_グローバルフック WH_GETMESSAGE |
Halbow 資料館の [メッセージを盗む: サブクラス化とフック関数] と [メッセージを捕まえる: ローカルフック] に解説がありますが,これらはローカルフックの例です.
本ページのサンプルは,フック関数 WH_GETMESSAGE を DLL 内に置き,グローバルフックとして使用する例です. |
グローバルフックとローカルフックの違いは,SetWindowsHookEx 関数の引数の違いです.
ローカルフックの場合は,次のように,第 3 引数の値を 0,第 4 引数の値を GetCurrentThreadID にすれば,多くの場合十分です.ローカルフックの場合,DLL にする必要はありません.
|
SetWindowsHookEx(WH_GETMESSAGE, @MyHookProc, 0, GetCurrentThreadID);
|
図1
実行画面
|
リスト1
グローバルフック WH_GETMESSAGE のテスト |
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls;
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+100;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
// DLL内の呼出関数類
function StartGetMessageHook(Wnd: HWND): Boolean; stdcall;
external 'PLHOOKGETMESSAGE.DLL';
procedure StopGetMessageHook; stdcall; external 'PLHOOKGETMESSAGE.DLL';
//=============================================================================
// フォーム生成時の処理
// UIPI対応処理(管理者権限で実行してもフックを可能にする)
// クラス名とタイトルを一覧表示するためのListViewの設定
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
const
MSGFLT_ADD = 1;
MSGFLT_REMOVE = 2;
var
DLLHandle : THandle;
FuncFilter : function (msg: Cardinal; dwFlag: DWORD): BOOL; stdcall;
LStyle : LongInt;
begin
//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+100, MSGFLT_ADD);
end;
end;
finally
FreeLibrary(DLLHandle);
end;
end;
Caption := 'WH_GETMESSAGE テスト';
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;
//=============================================================================
// 本Form破棄の時にはフックを解除
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
if hHookLib <> 0 then begin
StopGetMessageHook;
FreeLibrary(hHookLib);
hHookLib := 0;
end;
end;
//=============================================================================
// フックを有効にする
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
if hHookLib = 0 then begin
hHookLib := LoadLibrary('PLHOOKGETMESSAGE.DLL');
StartGetMessageHook(Self.Handle);
end;
end;
//=============================================================================
// フックを無効にする
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
FormDestroy(nil);
end;
//-----------------------------------------------------------------------------
// DLLでPostしたメッセージ通知を受取る
//
// DLL側で以下の値をセットしている
// Msg.wParam メッセージ識別子
// Msg.lParam メッセージを受取るウィンドウのハンドル値
//-----------------------------------------------------------------------------
procedure TForm1.WMAPPMessage(var Msg: TMessage);
var
LTargetWnd : HWND;
LClass : String;
LTitle : String;
begin
if Msg.Msg = WM_APP + 100 then begin
//ここのWM_XXXXの(メッセージ識別子)を変更すれば
//WH_GETMESSAGEフックがどんなメッセージを捕捉可能かを確認可能
if Msg.WParam = WM_LBUTTONDOWN then begin
LTargetWnd := Msg.LParam;
LClass := GetWindowClassNameStr(LTargetWnd);
LTitle := GetWindowTitleStr(LTargetWnd);
DisplayWindowInfo(LClass, LTitle);
end;
end;
end;
//-----------------------------------------------------------------------------
// ListViewにCreateしたウィンドウのクラス名とタイトルを表示
//-----------------------------------------------------------------------------
procedure TForm1.DisplayWindowInfo(ClassName, TitleStr: String);
var
LItem : TListItem;
begin
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.
リスト2
サンプルプログラムで使用している DLL のプロジェクトソース |
library plHookGetMessage;
uses
plHookGetMessageUnit in 'plHookGetMessageUnit.pas';
//-----------------------------------------------------------------------------
// 外部からDLL内のメソッドを利用可能にするためのオマジナイ
//-----------------------------------------------------------------------------
exports
StartGetMessageHook,
StopGetMessageHook;
end.
リスト3
サンプルプログラムで使用している DLL のコード |
unit plHookGetMessageUnit;
interface
uses
Windows, Messages;
//外部のアプリケーションから使用する関数類
function StartGetMessageHook(HostWnd: HWND): Boolean; stdcall;
procedure StopGetMessageHook; stdcall;
implementation
//共有メモリの内容の構造体
type
PHookInfo = ^THookInfo;
THookInfo = record
HookHandle : HHOOK;
HostWnd : HWND;
end;
var
//メモリマップドファイルのハンドル
hMapFile : THandle;
const
//メモリマップドファイル名
MapFileName = 'HookGetMessage';
//-----------------------------------------------------------------------------
// 共有メモリアクセスのための準備
//
// 成功すると0を返す.失敗すると負数を返す.
// 負の値で処理を分岐できるようになっているが,このコードでは未使用.
//-----------------------------------------------------------------------------
function MapFileMemory(var AMapWnd: THandle; var ApMap: Pointer):integer;
begin
//メモリマップドファイルを開く
AMapWnd := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, 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);
exit;
end;
Result := 0;
end;
end;
//-----------------------------------------------------------------------------
// 共有メモリアクセスの後始末
// 割当てたメモリがあればビューを解除
// ハンドルがあればクローズ
//-----------------------------------------------------------------------------
procedure UnMapFileMemory(AMapWnd: THandle; ApMap: Pointer);
begin
if ApMap <> nil then UnmapViewOfFile(ApMap);
if AMapWnd <> 0 then CloseHandle(AMapWnd);
end;
//-----------------------------------------------------------------------------
// フックのコールバック関数
// このDLLを使用したアプリにメッセージを送る
// 検出するメッセージは呼出プログラムからフック開始時に引数で指定
//
// nCoe フックコード
// wParam PM_REMOVE この関数通過後メッセージキューからメッセージが削除される
// PM_NOREMOVE PeekMessageで覗かれているだけでキューから削除されない
// lParma メッセージに関する情報を格納したTMsg構造体のポインタ
//
// TMsg = packed record
// hwd : HWND メッセージを受取るウィンドウのハンドル
// message : UNIT メッセージ識別子
// wParam : WPARAM メッセージ固有の32ビット値
// lParam : LPARAM メッセージ固有の32ビット値
// time : DWORD メッセージがボストされた時刻
// pt : TPoint マウスカーソルの位置
//
// GetMesageまたはPeekMessage関数が呼出される前にこのフック関数を通過する
// このフック関数内でメッセージのパラメータを変更すると,変更したパラメータが
// 目的のウィンドウに渡される
//-----------------------------------------------------------------------------
function MyHookProc(nCode: Integer; wPar: WPARAM; lPar: LPARAM): LRESULT; stdcall;
var
LWnd : THandle;
LpMap : Pointer;
LpMsg : PMsg;
LTargetWnd : HWND;
LPostMsg : Integer;
begin
Result := 0;
if MapFileMemory(LWnd, LpMap) <> 0 then exit;
if nCode < 0 then begin
Result := CallNextHookEx(pHookInfo(LpMap)^.HookHandle, nCode, wPar, lPar);
end else begin
if nCode = HC_ACTION then begin
if wPar = PM_REMOVE then begin
LpMsg := PMsg(lPar);
LTargetWnd := LpMsg^.hwnd;
LPostMsg := LpMsg^.message;
if LTargetWnd <> pHookInfo(LpMap)^.HostWnd then begin
PostMessage(pHookInfo(LpMap)^.HostWnd,
WM_APP + 100,
LPostMsg,
LTargetWnd);
end;
end;
end;
Result := CallNextHookEx(pHookInfo(LpMap)^.HookHandle, nCode, wPar, lPar);
end;
UnMapFileMemory(LWnd, LpMap);
end;
//-----------------------------------------------------------------------------
// フック関数の登録
// 登録するフック関数はMyHookProc
//-----------------------------------------------------------------------------
function StartGetMessageHook(HostWnd: HWND): Boolean; stdcall;
var
LMapWnd : THandle;
LpMap : Pointer;
begin
Result := False;
//メモリマップドファイル使用準備
MapFileMemory(LMapWnd, LpMap);
if LpMap = nil then begin
LMapWnd := 0;
end else begin
//フック情報構造体初期化とフック関数の登録
pHookInfo(LpMap)^.HostWnd := HostWnd;
//フックをインストール
//ローカルフックの場合は3番目の引数は0(null)でOK
//グローバルの場合はDLLのインスタンス
//4番目はフック対象のスレッドID(システム全体の時は0)
pHookInfo(LpMap)^.HookHandle := SetWindowsHookEx(WH_GETMESSAGE,
@MyHookProc,
hInstance,
0);
//フック成功
if pHookInfo(LpMap)^.HookHandle > 0 then begin
Result := True;
end;
//メモリマップドファイル使用終了処理
UnMapFileMemory(LMapWnd, LpMap);
end;
end;
//-----------------------------------------------------------------------------
// フックの解除
//-----------------------------------------------------------------------------
procedure StopGetMessageHook; stdcall;
var
LMapWnd : THandle;
LpMap : Pointer;
begin
//メモリマップドファイル使用準備
MapFileMemory(LMapWnd, LpMap);
if LpMap = nil then begin
LMapWnd := 0;
end else 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),
MapFileName);
end;
//-----------------------------------------------------------------------------
// ユニット終了処理部
// メモリマップドファイルのクローズ
//-----------------------------------------------------------------------------
finalization
begin
if hMapFile <> 0 then CloseHandle(hMapFile);
end;
end.
[300_グローバルフック WH_CALLWNDPROC] と [310_グローバルフック WH_CALLWNDPROCRET] ではメッセージセージを選択してテストするサンプルを提供しているので,こちらも作成してみました.
フック対象メッセージをコンボボックスから選択するようにしています.別のメッセージを選択するとフックを中止しますので,再度フック開始ボタンをクリックします.
コンボボックスには Delphi 7 当時で扱える 227 の WM_XXXX メッセージリストをリソースから読み出してセットしていますが,WH_GETMESSAGE でこれらの全てがフックできるわけではありません.
図ではマウスボタンの操作をフックしていますが,ボタンの位置は表示されていません.マウスの位置情報は lParam に格納されています.このサンプルコードでは wParam の値しか DLL から取得していないので表示できません.
これらの値を操作する等,DLL を使用する実際のアプリケーションではそのアプリごとに,ある程度 DLL 内で処理する必要もあるでしょう.本サイトのサンプルプログラム集は,あくまでも動作確認のテストプログラムです. |
|
図2
設計時画面 |
|
図3
実行開始
- メッセージを選択して
- [Start Hook] をクリック
|
|
図4
フック中
- 起動中のワードでマウス操作
- タスクバーから起動中のエクセルを選択
- エクセルでマウス操作
|
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, Buttons, ExtCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
btnClear: TSpeedButton;
btnStart: TButton;
btnStop: TButton;
ComboBox1: TComboBox;
Panel2: TPanel;
ListView1: TListView;
procedure FormDestroy(Sender: TObject);
procedure btnStartClick(Sender: TObject);
procedure btnStopClick(Sender: TObject);
procedure btnClearClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ComboBox1CloseUp(Sender: TObject);
protected
procedure DisplayWindowInfo(AClass, ATitle: String; wParam: Cardinal);
function GetWindowTitleStr(hWindow: HWND): String;
function GetWindowClassNameStr(hWindow: HWND):string;
private
{ Private declarations }
hHookLib : THANDLE;
procedure WMAPPMessage(var Msg: TMessage); message WM_APP+100;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
// DLL内の呼出関数類
function StartGetMessageHook(Wnd: HWND; AMsg: Integer): Boolean; stdcall;
external 'PLHOOKGETMESSAGEMSG.DLL';
procedure StopGetMessageHook; stdcall; external 'PLHOOKGETMESSAGEMSG.DLL';
//=============================================================================
// フォーム作成時の処理
//
// リソースからWM_XXXのリストを取出してコンポボックスにセット
// ウィンドウメッセージリストのリソースファイルはMessageList.txt
// セットするのはWM_XXXの文字列とその整数値
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
const
MSGFLT_ADD = 1;
MSGFLT_REMOVE = 2;
var
DLLHandle : THandle;
FuncFilter : function (msg: Cardinal; dwFlag: DWORD): BOOL; stdcall;
LResource : TResourceStream;
LList : TStringList;
i : Integer;
LText1 : String;
LText2 : String;
LPos : Integer;
LStyle : Integer;
begin
//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 + 100, MSGFLT_ADD);
end;
end;
finally
FreeLibrary(DLLHandle);
end;
end;
LResource := TResourceStream.Create(hInstance, 'MessageList', 'TEXT');
LList := TStringList.Create;
ComboBox1.Items.Clear;
try
LList.LoadFromStream(LResource);
for i := 0 to LList.Count - 1 do begin
LPos := Pos('=', LList[i]);
LText1 := Trim(Copy(LList[i], 1, LPos - 1));
LText2 := Trim(Copy(LList[i], LPos + 1, Length(LList[i])));
ComboBox1.Items.AddObject(LText1, TObject(StrToInt(LText2)));
end;
finally
FreeAndNil(LResource);
FreeAndNil(LList);
end;
//垂直スクロールバーを最初から表示
LStyle := GetWindowLong(ListView1.Handle, GWL_STYLE);
ShowScrollBar(ListView1.Handle, SB_VERT, True);
SetWindowLong(ListView1.Handle, GWL_STYLE, LStyle);
end;
//=============================================================================
// 本Form破棄の時にはフックを解除
//=============================================================================
procedure TForm1.FormDestroy(Sender: TObject);
begin
if hHookLib <> 0 then begin
btnStart.Enabled := True;
btnStop.Enabled := False;
StopGetMessageHook;
FreeLibrary(hHookLib);
hHookLib := 0;
end;
end;
//=============================================================================
// フックを有効にする
//=============================================================================
procedure TForm1.btnStartClick(Sender: TObject);
var
LIndex : Integer;
LRevMsg : Integer;
begin
LRevMsg := 0;
LIndex := ComboBox1.ItemIndex;
if (LIndex = -1) then begin
if (Trim(ComboBox1.Text) <> '') then begin
LRevMsg := StrToInt(Trim(ComboBox1.Text));
end;
end else begin
LRevMsg := Integer(ComboBox1.Items.Objects[LIndex]);
end;
if LRevMsg > 0 then begin
if hHookLib = 0 then begin
hHookLib := LoadLibrary('PLHOOKGETMESSAGEMSG.DLL');
StartGetMessageHook(Self.Handle, LRevMsg);
btnStart.Enabled := False;
btnStop.Enabled := True;
end;
end;
end;
//=============================================================================
// フックを無効にする
//=============================================================================
procedure TForm1.btnStopClick(Sender: TObject);
begin
FormDestroy(nil);
end;
//=============================================================================
// ListViewのアイテムをクリア
//=============================================================================
procedure TForm1.btnClearClick(Sender: TObject);
begin
ListView1.Items.Clear;
ListView1.Update;
end;
//=============================================================================
// コンボボックスでフック対象メッセージを変更したら一度フックを止める
//=============================================================================
procedure TForm1.ComboBox1CloseUp(Sender: TObject);
begin
btnStopClick(nil);
end;
//-----------------------------------------------------------------------------
// DLL側がPostしたメッセージ通知を受取る
//
// DLL側はPostMessageで以下の値を送っている
// 指定したメッセージを発生したウィンドウのハンドル
// 各メッセージに対応したwParamの値
//-----------------------------------------------------------------------------
procedure TForm1.WMAPPMessage(var Msg: TMessage);
var
LTargetWnd : HWND;
LClass : String;
LTitle : String;
LwParam : Cardinal;
begin
if Msg.Msg = WM_APP + 100 then begin
LTargetWnd := Msg.wParam;
LClass := GetWindowClassNameStr(LTargetWnd);
LTitle := GetWindowTitleStr(LTargetWnd);
LwParam := Msg.LParam;
DisplayWindowInfo(LClass, LTitle, LwParam);
end;
end;
//-----------------------------------------------------------------------------
// ListViewにフックしたウインドウのクラス名とタイトル,wParam値を表示
// wParam値は,下位ワードと上位ワード値に分けて16進数で表示
//-----------------------------------------------------------------------------
procedure TForm1.DisplayWindowInfo(AClass, ATitle: String; wParam: Cardinal);
var
LItem : TListItem;
LLow : WORD;
LHi : WORD;
begin
LLow := LOWORD(wParam);
LHi := HIWORD(wParam);
LItem := ListView1.Items.Add;
LItem.Caption := AClass;
LItem.SubItems.Add (ATitle);
LItem.SubItems.Add (Format('$%.4x ', [LHi]));
LItem.SubItems.Add (Format('$%.4x ', [LLow]));
//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.
リスト5
ほとんど同じパターンの DLL のソースコード |
unit plHookGetMessageMsgUnit;
interface
uses
Windows, Messages;
//外部のアプリケーションから使用する関数類
function StartGetMessageHook(HostWnd: HWND; AMsg: Integer): Boolean; stdcall;
procedure StopGetMessageHook; stdcall;
implementation
//共有メモリの内容の構造体
type
PHookInfo = ^THookInfo;
THookInfo = record
HookHandle : HHOOK;
HostWnd : HWND;
RevMessage : Integer;
end;
var
//メモリマップドファイルのハンドル
hMapFile : THandle;
const
//メモリマップドファイル名
MapFileName = 'HookGetMessageMsg';
//-----------------------------------------------------------------------------
// 共有メモリアクセスのための準備
//
// 成功すると0を返す.失敗すると負数を返す.
// 負の値で処理を分岐できるようになっているが,このコードでは未使用.
//-----------------------------------------------------------------------------
function MapFileMemory(var AMapWnd: THandle; var ApMap: Pointer):integer;
begin
//メモリマップドファイルを開く
AMapWnd := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, 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);
exit;
end;
Result := 0;
end;
end;
//-----------------------------------------------------------------------------
// 共有メモリアクセスの後始末
// 割当てたメモリがあればビューを解除
// ハンドルがあればクローズ
//-----------------------------------------------------------------------------
procedure UnMapFileMemory(AMapWnd: THandle; ApMap: Pointer);
begin
if ApMap <> nil then UnmapViewOfFile(ApMap);
if AMapWnd <> 0 then CloseHandle(AMapWnd);
end;
//-----------------------------------------------------------------------------
// フックのコールバック関数
// このDLLを使用したアプリにメッセージを送る
// 検出するメッセージは呼出プログラムからフック開始時に引数で指定
//
// nCoe フックコード
// wParam PM_REMOVE この関数通過後メッセージキューからメッセージが削除される
// PM_NOREMOVE PeekMessageで覗かれているだけでキューから削除されない
// lParma メッセージに関する情報を格納したTMsg構造体のポインタ
//
// TMsg = packed record
// hwd : HWND メッセージを受取るウィンドウのハンドル
// message : UNIT メッセージ識別子
// wParam : WPARAM メッセージ固有の32ビット値
// lParam : LPARAM メッセージ固有の32ビット値
// time : DWORD メッセージがボストされた時刻
// pt : TPoint マウスカーソルの位置
//
// GetMesageまたはPeekMessage関数が呼出される前にこのフック関数を通過する
// このフック関数内でメッセージのパラメータを変更すると,変更したパラメータが
// 目的のウィンドウに渡される
//-----------------------------------------------------------------------------
function MyHookProc(nCode: Integer; wPar: WPARAM; lPar: LPARAM): LRESULT; stdcall;
var
LWnd : THandle;
LpMap : Pointer;
LpMsg : PMsg;
LTargetWnd : HWND;
LPostMsg : Integer;
begin
Result := 0;
if MapFileMemory(LWnd, LpMap) <> 0 then exit;
if nCode < 0 then begin
Result := CallNextHookEx(pHookInfo(LpMap)^.HookHandle, nCode, wPar, lPar);
end else begin
if nCode = HC_ACTION then begin
if wPar = PM_REMOVE then begin
LpMsg := PMsg(lPar);
LTargetWnd := LpMsg^.hwnd;
LPostMsg := LpMsg^.message;
//LPostMsgがStartGetMessageHookの引数の値に等しい時だけ送信
if LPostMsg = pHookInfo(LpMap)^.RevMessage then begin
PostMessage(pHookInfo(LpMap)^.HostWnd,
WM_APP + 100,
LTargetWnd,
LpMsg.wParam);
end;
end;
end;
Result := CallNextHookEx(pHookInfo(LpMap)^.HookHandle, nCode, wPar, lPar);
end;
UnMapFileMemory(LWnd, LpMap);
end;
//-----------------------------------------------------------------------------
// フック関数の登録
// 登録するフック関数はMyHookProc
// AMsgはこのDLLの関数を外部から使用する時に指定するメッセージ(WM_XXXX)
//-----------------------------------------------------------------------------
function StartGetMessageHook(HostWnd: HWND; AMsg: Integer): Boolean; stdcall;
var
LMapWnd : THandle;
LpMap : Pointer;
begin
Result := False;
//メモリマップドファイル使用準備
MapFileMemory(LMapWnd, LpMap);
if LpMap = nil then begin
LMapWnd := 0;
end else begin
//フック情報構造体初期化とフック関数の登録
pHookInfo(LpMap)^.HostWnd := HostWnd;
pHookInfo(LpMap)^.RevMessage := AMsg;
//フックをインストール
//ローカルフックの場合は3番目の引数は0(null)でOK
//グローバルの場合はDLLのインスタンス
//4番目はフック対象のスレッドID(システム全体の時は0)
pHookInfo(LpMap)^.HookHandle := SetWindowsHookEx(WH_GETMESSAGE,
@MyHookProc,
hInstance,
0);
//フック成功
if pHookInfo(LpMap)^.HookHandle > 0 then begin
Result := True;
end;
//メモリマップドファイル使用終了処理
UnMapFileMemory(LMapWnd, LpMap);
end;
end;
//-----------------------------------------------------------------------------
// フックの解除
//-----------------------------------------------------------------------------
procedure StopGetMessageHook; stdcall;
var
LMapWnd : THandle;
LpMap : Pointer;
begin
//メモリマップドファイル使用準備
MapFileMemory(LMapWnd, LpMap);
if LpMap = nil then begin
LMapWnd := 0;
end else 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),
MapFileName);
end;
//-----------------------------------------------------------------------------
// ユニット終了処理部
// メモリマップドファイルのクローズ
//-----------------------------------------------------------------------------
finalization
begin
if hMapFile <> 0 then CloseHandle(hMapFile);
end;
end.
|