[ 第４章メッセージを盗む：サブクラス化とフック関数 ]

前章で作った TSpeedBtn クラスは、押しボタンとしての外見は持っていないが、自分自身を描画しマウスクリックには応答することができた。このクラスのオブジェクトは、 Object Pascal という言語上のオブジェクトであってもＯＳが認識するウィンドウではないので、ＯＳが発行するメッセージを受け取ることができない。前章のテストプログラムでは、親ウィンドウのメッセージハンドラから Dispatch( ) メソッドを使ってメッセージを「分けてもらって」いた。クラスのこのような仕様は、重大な欠陥であると言わなければならない。コンストラクタをコードによって呼び出してオブジェクトを作って初期化したあとは、自前でメッセージを取得してイベントを発生し、最後に WM_DESTROY によって自分を解放する（ようにユーザーには見える）のが望ましい。そうでなければ、 TSpeedBtn クラスのようなオブジェクトを使って、電卓アプリケーションを作ることを想像してほしい。二十個以上ものボタンにいちいちメッセージを配ったり廃棄したりするのはいかにも煩わしいし、何よりもオブジェクトを使う意味がない。この章では、自前で親ウィンドウからメッセージを「盗む」方法を考察しよう。そして、自動的にオブジェクトにメッセージを配ったり、オブジェクトを廃棄したりするクラスを設計しよう。このクラスを使うユーザーには、オブジェクトは自立しているように見える訳だ。

メッセージを「盗む」多くの方法が知られている。ここでは、「サブクラス化」とメッセージのフック関数を試してみる。これらの方法は、プログラミングテクニックとしては一般的で重要な手法であり、どの教科書にも載っている。多くの場合、メッセージを盗んで独自の処理をすることで、コントロールやシステムデバイスをカスタマイズするために使用される。この章では、もっぱらメッセージを盗んで TSpeedBtn に配送するクラスの構築のために使うが、これらの手法の一般的側面もＲＡＤ環境でテストしている。

4－0 この章の内容

４－１クラス情報とウィンドウ情報

「サブクラス化」とはもともとＯＯＰの一般的な用語であり、上位クラス（スーパークラス）から、下位クラスが継承のメカニズムによって派生しメソッドやプロパティーを追加してカスタマイズする過程を意味している。ここではより狭義で使っており、既存クラスの動作処理を変更する事を意味している。ここで言うサブクラス化とは、簡単に言えば、ウィンドウが持っているウィンドウ関数を任意の関数に入れ替えることによってメッセージの処理をカスタマイズする方法である。 Generic01.dpr ではじめてウィンドウをつくったときのことを思い出してほしい。 TWndClass レコードの各フィールドを定義してから、これを RegisterClass( )で登録し、CreateWindowEx( ) でウィンドウを作る。どのウィンドウもこのような方法で作られているに違いない。このとき、ウィンドウ関数は TWndClass レコードの lpfnWndProc フィールドにそのアドレスを格納していた。つまり、ウィンドウ関数は、ウィンドウの属性ではなく、その雛形となったクラスの属性である。言い換えれば、ウィンドウはクラスのインスタンスであるが、ウィンドウ関数はクラスの属性として定義され、そのインスタンスはすべて同じウィンドウ関数を持つことになる。 Win32 のこのような仕様は、似ているけれども少しだけ違うウィンドウをつくる場合に、同じクラスをつかって CreateWindowEx( ) のパラメータを少し変えることで実現できるようにするために考案されたものだろう。しかし、性質が異なるウィンドウが共通のウィンドウ関数をもつことは、コードを複雑にするだけで合理的とは思えない。このことを解決する一つの手法がここで言うサブクラス化である。作成されたあとに、ウィンドウ情報にアクセスして、ウィンドウ関数を入れ替えてしまえばよいのだ。この節では、特定のウィンドウのクラス情報（TWndClass の各フィールドの値）とウィンドウ情報（ CreateWindowEx( ) のパラメータに相当する）にアクセスする方法について考察する。

ＶＣＬの TForm のインスタンスは、その実装方法がＶＣＬの深い階層によって厚化粧されたものであっても、ハンドルをもつウィンドウであることには違いないだろう。まず、ＲＡＤ環境でクラス情報とウィンドウ情報にアクセスする関数を作ろう。

以下に、Main.pas の全リストを示す。実行時に Button1 を押したときの様子をこのコードリストの下の図に示す。

unit Main;

interface

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

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

var
  Form1: TForm1;

implementation

{$R *.DFM}

function WindowInfo(sobject: string;hWindow: HWND): string;
var
  s: string;
  c: array[0..50] of Char;
begin
  GetWindowText(hWindow,c,50);
  s := 'WindowInfo of '+sobject+#13#13;
  s := s+'TEXT = '+ string(c)+#13;
  s := s+'HANDLE = $'+ AIntToHex(hWindow,8)+#13;
  s := s+'EXSTYLE = $'+ AIntToHex(GetWindowLong(hWindow,GWL_EXSTYLE),8)+#13;
  s := s+'STYLE = $' + AIntToHex(GetWindowLong(hWindow,GWL_STYLE),8)+#13;
  s := s+'WNDPROC = $' + AIntToHex(GetWindowLong(hWindow,GWL_WNDPROC),8)+#13;
  s := s+'HINSTANCE = $'+ AIntToHex(GetWindowLong(hWindow,GWL_HINSTANCE),8)+#13;
  s := s+'HWNDPARENT = $'+ AIntToHex(GetWindowLong(hWindow,GWL_HWNDPARENT),8)+#13;
  s := s+'ID = '+ AIntToStr(GetWindowLong(hWindow,GWL_ID));
  result := s;
end;

function ClassInfo(hWindow:HWND):string;
var
  WC: TWndClass;
  c: array[0..50] of Char;
  s: string;
  i: integer;
  w: word;
begin
  GetClassName(hWindow,c,50);
  GetClassInfo(hInstance,c,WC);
  s := 'ClassInfo of '+ string(c)+#13#13+
       'Style = $'+ AIntToHex(WC.Style,8)+#13+
       'WndProc = $' + AIntToHex(integer(WC.lpfnWndProc),8)+#13+
       'hInstance = $' + AIntToHex(WC.hInstance,8)+#13+
       'ClsExtra = ' + AIntToStr(WC.cbClsExtra)+' byte'#13;
  if WC.cbClsExtra > 0 then begin
    s := s+'  ClsExtraData = ';
    for i := 0 to (WC.cbClsExtra div 2) -1 do begin
      w := GetClassWord(hWindow,i);
      s := s+AIntToHex(LOBYTE(w),1)+AIntToHex(HIBYTE(w),1);
    end;
    s := s+#13;
  end;
  s := s+'WndExtra = ' + AIntToStr(WC.cbWndExtra)+' byte'#13;
  if WC.cbWndExtra > 0 then begin
    s := s+'  WndExtraData = ';
    for i := 0 to (WC.cbWndExtra div 2) -1 do begin
      w := GetWindowWord(hWindow,i);
      s := s+AIntToHex(LOBYTE(w),1)+AIntToHex(HIBYTE(w),1);
    end;
    s := s+#13;
  end;
  s := s+ 'hIcon = $' + AIntToHex(WC.hIcon,8)+#13+
       'hBrush = $' + AIntToHex(WC.hbrBackground,8)+#13+
       'MenuName = ' + string(WC.lpszMenuName);
  result := s;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  s: string;
begin
  s := Main.ClassInfo(Form1.Handle);
  s := s + #13#13+ WindowInfo('TForm1',Form1.Handle);
  Label1.Caption := s;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  s: string;
begin
  s := Main.ClassInfo(Application.Handle);
  s := s + #13#13+ WindowInfo('TApplication',Application.Handle);
  Label1.Caption := s;
end;

end.

コードの大部分は、WindowInfo( ) 関数と ClassInfo( ) 関数の実装に費やされている。クラスの情報は、GetClassInfo( ) ＡＰＩによって得られる。

第一パラメータはインスタンスハンドル（ Delphiではグローバル変数 hInstance として参照可能）、第二パラメータはクラス名、第三パラメータは情報を受け取る TWndClass 型レコードの変数を指定する。この第二パラメータであるクラス名を取得するために GetClassName( ) ＡＰＩを使っている。

この関数は、ウィンドウハンドルを渡すと lpClassName にクラス名を返してくれる。 nMaxCount はクラス名を受け取るバッファの長さである。 ClassInfo( ) 関数の残りのコードは、戻り値の文字列に情報を格納するための汚いコードである。一方、ウィンドウ情報は、GetWindoLong( ) ＡＰＩによって得られる。

のひとつを指定すると、対応する情報を戻り値として返してくれる。ウィンドウ作成のときの CreateWindow( ) ＡＰＩの第二パラメータによって、各ウィンドウにはテキストが関連づけられている。このテキストは、タイトルバーがあるウィンドウではタイトルバーに表示され、ボタンなどの子ウィンドウではキャプションとして表示されるが、表示しないウィンドウも多い。このテキストは、GetWindowText( ) ＡＰＩで受け取れる。パラメータは、 GetClassName( ) のときと同じだ。以上の説明で上記のコードを理解できるだろう。 Button1 をクリックすると Label1 に Form1 の情報が表示される。 Button2 をクリックすると Application オブジェクトの情報が表示される。表示された内容について調べてみよう。なお、ハンドルの値など幾つかの情報は、 Delphi のバージョンやインスタンスごとに異なるので、右図と必ずしも一致しない事に注意してほしい。ここでは、右図に示された情報について調べることにする。

まず、この節のメインテーマであるウィンドウ関数のアドレスに注目しよう。 TForm1 クラスの WndProc に表示される値と Form1 のウィンドウ情報の WNDPROC に表示される値が同じでないことは、興味深い。このことは、ＶＣＬのどこかの階層でサブクラス化によってウィンドウ関数が取り替えられていることを意味している。つぎに、Form1 の HWNDPARENT の値がゼロではないことに注目しよう。これは、Form1 が所有された(Owned)ウィンドウであることを示している。 Form1 の最小化ボタンを押してもタスクバーに吸い込まれるようなアニメーションが見られないのはトップレベルウィンドウではないからだ。 HWNDPARENT の値を憶えておいて、Button2 を押してみよう。 Apllication オブジェクトのハンドルの値と同じであることが分かるだろう。さらに、Application の HWNDPARENT の値はゼロであることが分かるだろう。つまり Form1 は Application ウィンドウに所有されたウィンドウであることが分かる。 Application ウィンドウは、ＲＡＤプログラムのアプリケーションに暗黙のうちに作られるトップレベルウィンドウである。そのテキストは、プロジェクトの名前と同じである。 Apllication ウィンドウは、ディスプレイの中央に位置し幅と高さがゼロ（したがって目に見えない）のウィンドウである。

TForm1 の他の情報について調べよう。クラスの style の値は $00000008 である。これは、Windows.pas から CS_DBLCLKS = 8 であることがわかり、Form1 はマウスボタンのダブルクリックに応答できることを示している。ウィンドウの STYLE は $16CF0000 である。この値は、

を使うと、WS_VISIBLE or WS_CLIPSIBLINGS or WS_CLIPCHILDREN or WS_OVERLAPPEDWINDOW とも表せる。また拡張スタイル EXSTYLE は $00010100 であるから

となっている。これらの情報は、Form1 のプロパティーがデフォルトの場合に得られたものであり、オブジェクトインスペクタでプロパティーを変えるとウィンドウスタイルは勿論、他の情報も変化する可能性がある。試してみてほしい。

最後に、 WindowInfo( ) 関数と ClassInfo( ) 関数は、TForm クラスだけではなく TWinControl の派生クラスである TButton や TMemo、TListBox などのクラスとオブジェクトにも適用できることを言っておきたい。そこで、この二つの関数を UtilFunc.pas に実装しよう。 Interface 部の InitMenuCommand( ) の下に

  function WindowInfo(sobject: string;hWindow: HWND): string;
  function ClassInfo(hWindow:HWND):string;

の宣言を追加し、Main.pas から関数の実装部分を切り取って、UtilFunc.pas の実装部の InitMenuCommand( ) 手続きの下に貼り付ける。以上で完了である。最終的に Main.pas の実装部は以下のようになる。

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  s: string;
begin
  s := UtilFunc.ClassInfo(Form1.Handle);
  s := s + #13#13+ WindowInfo('TForm1',Form1.Handle);
  Label1.Caption := s;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  s: string;
begin
  s := UtilFunc.ClassInfo(Application.Handle);
  s := s + #13#13+ WindowInfo('TApplication',Application.Handle);
  Label1.Caption := s;
end;

end.

４－２サブクラス化の簡単な例

前節で GetWindowLong( ) ＡＰＩを使えば、ウィンドウの様々な情報を知ることができることを示した。ここでは、ＲＡＤ環境で Form1 のウィンドウ関数を入れ替えてサブクラス化する例を示すことにしよう。サブクラス化の手法に対する具体的なイメージをつかむことができるだろう。 Form1 のウィンドウ関数はＶＣＬの階層のどこかに埋もれていて、プログラマは普通にはそのソースコードにアクセスできない。このような状況のときでもサブクラス化するとメッセージを盗む事ができる。ここでは、WM_MOUSEMOVE メッセージだけをトラップして処理する例を示す。

unit Main;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormClick(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

var
  OriginalProc: TFNWndProc;

function SubClassProc(hWindow: HWND; Msg: UINT;
                       wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin
  result := CallWindowProc(OriginalProc,hWindow,Msg,wParam,lParam);
  case Msg of
    WM_MOUSEMOVE: begin
      Form1.Label1.Caption := ' X : '+IntToStr(LOWORD(lParam))+
                              '  Y : '+IntToStr(HIWORD(lParam));
    end;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  OriginalProc := Pointer(GetWindowLong(Handle,GWL_WNDPROC));
  SetWindowLong(Handle,GWL_WNDPROC,integer(@SubClassProc));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  SetWindowLong(Handle,GWL_WNDPROC,integer(OriginalProc));
end;

procedure TForm1.FormClick(Sender: TObject);
begin
  MessageDlg('You Clicked Me!',mtInformation,[mbOK],0);
end;

end.

実行時の様子を上図に示した。 Form1 の上でマウスポインタを移動させると、その座標が Label1 に表示されるのが分かるだろう。また、 Form1 をクリックするとメッセージダイアログが表示されることも確かめてほしい。上のリストを見ればわかるように、マウスの座標はサブクラス化した新しいウィンドウ関数 SubClassProc( ) から表示されている。またマウスのクリックイベントに対する応答は、Form1 の本来のイベントハンドラから実現している。コードを見ていこう。サブクラス化は、TForm1.FormCreate( ) ハンドラで行われる。まず、GetWindowLong( ) で本来のウィンドウ関数のアドレスを TFNWndProc 型のグローバル変数 OriginalProc に格納する。つぎに、SetWindowLong( ) ＡＰＩを使って、Form1 のウィンドウ関数を SubClassProc に入れ替える。これでサブクラス化の完了である。 SetWindowLong( ) は

と宣言されている。第二パラメータ nIndex には、GetWindowLong( ) の第二パラメータに指定できるものと同じものが指定できる。戻り値は置き換える前の値である。したがって、このハンドラのコードは次の一行にまとめることもできる。

サブクラス化を行ったら終端処理として、TForm1.FormDestroy( ) ハンドラで実行しているように終了時直前に元のウィンドウ関数に戻しておくことがこの手法の作法である。これを怠るとプログラムが正常に終了しないことが多い。 SubClassProc の形は、標準のウィンドウ関数と同じにする。また stdcall 規約を忘れないこと。この関数は、ＯＳによってコールされるのである。サブクラスのウィンドウ関数はメッセージを処理してもしなくても、 CallWindowProc( ) ＡＰＩによって元のウィンドウ関数を呼び出さなければならない。このようにして、何重ものサブクラス化が行われても、ウィンドウ関数の連鎖をたどって最終的にはオリジナルのウィンドウ関数にメッセージが届くことが保証される。もちろん、プログラマはサブクラスのウィンドウ関数でメッセージを完全に処理する決心をして、メッセージの流れをくい止めて後のウィンドウ関数に渡さずに完全に置き換える事もできる。しかし、そのような例は稀であり、ここで示したようにメッセージ伝達機構のある断面を「のぞき見て」から、本来の流れに戻すという手法が一般的であるし「完全犯罪」の可能性も高い。ここでは、メッセージの処理をする前に元のウィンドウ関数を呼び出している。 CallWindowProc( ) は、

と宣言されている。使い方は例を見ると理解できるだろう。サブクラスのウィンドウ関数でメッセージを処理する場合、その処理はこの例のように本来のウィンドウ関数での処理の「後に」行われるか、「先だって」行われるかは、目的とする動作に影響を及ばさないこともあるが、及ぼすこともあるのでよく検討することが大切である。

４－３フック関数の簡単な例

メッセージを盗み見るもう一つの方法であるフック関数を使って前節と同じ事をやってみよう。サブクラス化はプログラミングテクニックの一つであったのに対して、フック関数のインストールはＡＰＩ関数レベルでサポートされている「正式な」メッセージ処理方法である。使い方によっては、非常に強力な手法であり、全てのアプリケーションとシステムの共通リソースであるキーボードやマウスのマッピングを変更することもできるし、一つのプロセス内だけで有効なフック関数をインストールする事もできる。したがって、フック関数をインストールすることはサブクラス化の手法の補完的なものにとどまらない。ここでは、ＲＡＤ環境でどこかにあるはずのメッセージループから Form1 のウィンドウ関数に向けられて送り出されるメッセージを横取りして WM_MOUSEMOVE メッセージを処理するようなフック関数の例を示そう。

unit Main;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormClick(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

var
  Hook: HHOOK;
  hookParent: HWND;

function HookProc(code: Integer; wparam: WPARAM;
                     lparam: LPARAM): LRESULT; stdcall;
var
  Msg: PMsg;
begin
  result := 0;
  if (code = HC_ACTION) and (wparam = PM_REMOVE) then begin
    Msg := PMsg(lparam);
    if Msg^.hwnd = hookParent then begin

      case Msg^.message of

        WM_MOUSEMOVE:begin
          Form1.Label1.Caption := ' X : '+IntToStr(LOWORD(Msg^.lParam))+
                              '  Y : '+IntToStr(HIWORD(Msg^.lParam));
        end;

      end; // case
    end;
  end;
  CallNextHookEx(Hook,code,wparam,lparam);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Hook := SetWindowsHookEx(WH_GETMESSAGE,HookProc,0,
                               GetCurrentThreadID);
  hookParent := Handle;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  UnHookWindowsHookEx(Hook);
end;

procedure TForm1.FormClick(Sender: TObject);
begin
  MessageDlg('You Clicked Me!',mtInformation,[mbOK],0);
end;

end.

実行してみると前節の RADSubClass.exe と全く同じ動作をする事が分かるだろう。マウスポインタの座標の表示は、コードから分かるように HookProc( ) 関数で実現されている。それではコードを見ていこう。

フック関数のインストールは TForm1.FormCreate( ) ハンドラで SetWindowsHookEx( ) ＡＰＩで行っている。

第一パラメータでインストールするフック関数の種類を指定する。 Windows.pas にはここで指定できるパラメータとして

などが定義されている。例えば、キーボードのマッピングを変更するなら WH_KEYBOARD を指定する。ここでは、WH_GETMESSAGE を指定する。これは、メッセージループで GetMessage( ) によりメッセージキューからメッセージを取り出した直後に、システムにそのメッセージをフック関数に送ってもらうよう依頼している。ＲＡＤ環境のプログラミングでは、プログラマはメッセージループの存在を意識することはないが、それでもどこかにメッセージループがあるに違いない。 SetWindowsHookEx( ) の第二パラメータにはインストールするフック関数を指定する。フック関数の形は、

となっているが、各パラメータの意味は SetWindowsHookEx( ) の第一パラメータで指定したフック関数の種類により異なる。この例の WH_GETMESSAGE の場合は、code が HC_ACTION であるときそのメッセージを処理できる事を示している。 wparam はそのメッセージがメッセージキューから GetMessage( ) で取り去られるかどうかを示している。一般には、取り去られるのでこのパラメータが PM_REMOVE であるかどうか確認すればよい。lparam はメッセージ本体である TMsg レコードへのポインタを表している。

SetWindowsHookEx( ) の第三パラメータは、フック関数が実装されているモジュール（ＤＬＬ：ダイナミックリンクライブラリ）のハンドルを指定する。システムレベルのフック関数は、多くのアプリケーションから参照される必要があるので通常ＤＬＬに格納されている。ただし、最後のパラメータ dwThreadId がこのコードが実行されるプロセスでつくられたスレッドを指定しており、かつ、フック関数がこのプロセスのなかにある場合は第三パラメータ hmod にはゼロを指定しなければならない。今の場合は上の条件に合致するのでゼロを指定する。最後のパラメータ dwThreadId には、インストールされるフック関数が関連づけられるスレッドの番号を指定する。ゼロを指定すると、今の場合、全てのスレッドのメッセージループにインストールされることになる。スレッドとはマルチタスキングされる最小の実行単位のことである。一つの実行ファイルを実行すると一つのプロセスが生じる。プロセスでとくにスレッドを意識しないでプログラミングを行ったものは自動的に一つのスレッドを持つことになる。一つのプロセスは二つ以上のスレッドを持つことができる。例えば、時間のかかる印刷処理を裏スレッドでしながら、文書入力を表スレッドで行うワードプロセッサなどは多い。この最後のパラメータには、GetCurrentThreadID ＡＰＩの戻り値を指定する。 SetWindowsHookEx( ) は戻り値としてフック処理を識別するハンドルを返すので、これをグローバル変数 Hook に格納している。 TForm1.FormCreate( ) ハンドラの最後の一行はフック関数で参照するために、フックしたいウィンドウのハンドルをグローバル変数に格納している。以上で、フック関数のインストールは完了する。

終端処理として、TForm1.FormDestroy( ) ハンドラでフック関数のアンインストールを行っている。UnHookWindowsHookEx( ) のパラメータには解除したいフックハンドルを指定する。

フック関数を見てみよう。最初の if 文でこの関数で処理すべきメッセージかどうか判断している。つぎに、lparam を PMsg 型のポインタ Msg にキャストしている。 TMsg レコードについては、すでにメッセージループの説明のところで紹介したが、ここでも再掲する。

if 文で Msg^.hwnd が目的のウィンドウハンドルであることを確認してから、メッセージの処理を行っている。フック関数の最後には、フック関数の連鎖を断ち切らないために CallNextHookEx( ) ＡＰＩを呼び出して、インストールされている（かもしれない）次のフック関数にメッセージを渡す。

前節と本節では、サブクラス化とフック関数をインストールして、本来、Form1 のウィンドウ関数に送られる WM_MOUSEMOVE というメッセージを「盗み見て」、全く同じ動作をする二つのプログラムをつくった。一つのウィンドウ関数をサブクラス化の手法によって入れ替えると、そのウィンドウ関数に送られてくるメッセージをすべて見ることができる。しかし、他のウィンドウ関数に送られるメッセージを見ることは出来ない。これに対して、WH_GETMESSAGE を SetWindowsHookEx( ) の第一パラメータに指定してインストールしたフック関数では、メッセージループを通るそのスレッドのすべてのメッセージを見ることができるが、メッセージループを通らないメッセージは見ることは出来ない。後の章で説明するが、ボタンやリストボックス・エディットなどのコントロールは、親ウィンドウとの間で SendMessage( ) ＡＰＩを使ってメッセージを交換することでイベントの処理を行っている。SendMessage( ) を使って送られたメッセージはメッセージループを通過しないので、本節でインストールしたフック関数では捕まえられない。そのようなメッセージを捕まえるには、WH_CALLWNDPROC を第一パラメータに指定したフック関数を追加インストールすればよい。いずれにしても、サブクラス化とフック関数のインストールによって捕まえられるメッセージの種類や範囲は、必ずしも同じではない事に注意してほしい。

４－４サブクラス化によるメッセージの捕獲

前節までに、Win32 のメッセージ伝達機構に割り込んでメッセージを「盗み見る」方法として、サブクラス化とフック関数の例を挙げた。両方法とも、一般的で強力なプログラム手法であり、その使用法に難しいところは何もないことが分かって頂けたと思う。本章の最初に述べたとおり、このうちのいずれかの手法をつかってオブジェクトが自前でメッセージを取得したり、自分自身を解放したりする（ように見える）事ができるようにしよう。両方法とも一長一短があるが、ここではサブクラス化を採用しよう。ここでは、上の目的のための第一歩として、前章の最後につくった TSpeedBtn クラスにサブクラス化したウィンドウ関数からメッセージを配送する例を示そう。

program SubClass01;

uses
  windows,
  messages,
  UtilFunc in 'UtilFunc.pas',
  Test in 'Test.pas';

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  Clr: COLORREF;

  SP1,SP2: TSpeedBtn;
  OriginalProc: TFNWndProc;

//------------------------------------------------------------
//             Helper Handlers
//------------------------------------------------------------
function SubClassProc(hWindow: HWND; Msg: UINT;
                       wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
begin
  result := CallWindowProc(OriginalProc,hWindow,Msg,wParam,lParam);
  case Msg of
    WM_LBUTTONDOWN: begin
      AMsg.Msg := Msg;
      AMsg.WParam := WParam;
      AMsg.LParam := LParam;
      AMsg.Result := 0;
      SP1.Dispatch(AMsg);
      SP2.Dispatch(AMsg);
      end;

    WM_PAINT: begin
      AMsg.Msg := Msg;
      AMsg.WParam := WParam;
      AMsg.LParam := LParam;
      AMsg.Result := 0;
      SP1.Dispatch(AMsg);
      SP2.Dispatch(AMsg);
      end;

    WM_DESTROY: begin
      SP1.Free;
      SP2.Free;
      SetWindowLong(hWindow,GWL_WNDPROC,integer(OriginalProc));
      end;
  end; // case
end;  

//------------------------------------------------------------
//             Event Handlers
//------------------------------------------------------------
procedure OnCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := Msg.Msg;
  Clr := clrBtnFace;
  MakeInitMenu(hWindow);
  ChangeWindowSize(hWindow,400,300);
  CenterWindow(hWindow);

  SP1 := TSpeedBtn.Create(hWindow);
  SP1.Rect := SetDim(50,50,200,100);

  SP2 := TSpeedBtn.Create(hWindow);
  SP2.Rect := SetDim(50,120,200,170);

  OriginalProc := Pointer(GetWindowLong(hWindow,GWL_WNDPROC));
  SetWindowLong(hWindow,GWL_WNDPROC,integer(@SubClassProc));

end;

procedure OnTest(hWindow: HWND);
begin
  MessageBeep($FFFFFFFF);
end;

procedure OnCommand(var Msg: TMessage);
begin
  InitMenuCommand(Msg,OnTest);
end;

procedure OnEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := EraseBkGnd(Msg.Msg,Clr,Msg.WParam);
end;

procedure OnDestroy(var Msg: TMessage);
begin
  PostQuitMessage(0);
end;

//------------------------------------------------------------
//             Main Window Procedure
//------------------------------------------------------------
function MainWndProc(hWindow: HWND; Msg: UINT; WParam: WPARAM;
                      LParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
begin
  Result := 0;

  AMsg.Msg := hWindow;
  AMsg.WParam := WParam;
  AMsg.LParam := LParam;
  AMsg.Result := 0;

  case Msg of

//-------------  WM_CREATE  -----------------------------------

     WM_CREATE: OnCreate(AMsg);

//-------------  WM_COMMAND  ----------------------------------

     WM_COMMAND: OnCommand(AMsg);

//-------------  WM_ERASEBKGND  -------------------------------

     WM_ERASEBKGND: begin
       OnEraseBkgnd(AMsg);
       result := AMsg.Result;
     end;

//-------------  WM_DESTROY  ----------------------------------

     WM_DESTROY: OnDestroy(AMsg);

//-------- そのほかのメッセージの処理 ------
  else begin
    result := DefWindowProc( hWindow, Msg, wParam, lParam );
    end;

  end; // case
end;

//------------------------------------------------------------
//             Main Procedure
//------------------------------------------------------------
begin

  MakeMainWindow(@MainWndProc);

  Halt(MessageLoopNormal);

end.

コンパイルして実行すると SpeedBtn03.dpr と全く同じ動作をする。サブクラス化は OnCreate( ) ハンドラで TSpeedBtn クラスのインスタンスを二つつくった後に行われている。 WM_PAINT と WM_LBUTTONDOWN メッセージの捕獲とインスタンスへの配送は、サブクラス化したウィンドウ関数の中で行っている。したがって、メインウィンドウのウィンドウ関数からのハンドラには、Dispatch メソッドがないことに注目する事が重要である。インスタンスの破棄とサブクラス化からの回復も WM_DESTROY メッセージを捕獲して、新しいウィンドウ関数で行っている。

４－５ TMessageDispatcher の仕様とオブジェクト参照リスト

前節で示したように、サブクラス化によって、特定のメッセージの捕獲とオブジェクトへのメッセージの配送のメカニズムをメインウィンドウのウィンドウ関数から独立させることが出来た。また、オブジェクトの廃棄とサブクラス化の回復のプロセスも隠すことが出来た。しかし、これだけでは十分ではない。オブジェクトをクラスからつくるときに自動的にサブクラス化が行われていないからだ。さらに、どのメッセージを捕獲し、どのオブジェクトに Dispatch するのかという問題は解決されていない。この節以降で、この問題を解決しよう。

メッセージを自前で取得するすべてのオブジェクトの上位クラスとして TSubClass というクラスを設計しよう。このクラスからの派生クラスは、コンストラクタが実行されると自動的に親ウィンドウをサブクラス化する。また、オブジェクトは自分のメソッドの中で自分自身を解放することができない。ここでは、TMessageDispatcher というクラスをつくり、そのオブジェクト Dispatcher がサブクラス化したウィンドウ関数からメッセージを送ってもらい、それを TSubClass の派生オブジェクトに伝達し、親の解放時にはその子オブジェクトを解放する、というふうに制御することを考える。望ましい仕様を以下に列挙する。

以上の機能の TMessageDispatcher を実装するまえに、仕様２．について考えてみよう。Delphi の Object Pascal でのオブジェクト参照は、３２ビットのポインタであるから integer にキャストする事ができる。また、親のウィンドウハンドルも HWND = integer である。プログラムで TSubClass の派生オブジェクトがいくつ作られるかあらかじめ予期することはできないので、これらのリストは要素数が動的に変化するものでなくてはならない。ＶＣＬには、この仕様にぴったりの TList というポインタのリストを保持するクラスがある。 TList は Classes ユニットに実装されているので、ここでは自前の TIntegerList クラスを作ることにしよう。それでは早速 TIntegerList を以下の手順で作ってテストすることにしよう。

Test.pas に TIntegerList クラスを実装する。以下に全リストを示す。

unit Test;

interface

uses
  windows,messages;

//-----------------  TIntegerList ------------------------------
const
  MaxItem = 200000;

type
TIntegerArray = array[0..MaxItem] of Integer;
PIntegerArray = ^TIntegerArray;

TIntegerList = class(TObject)
private
  FPointer: PIntegerArray;
  FCount: integer;
  FSize: integer;
  FReAllocSize: integer;
  FInitialSize: integer;
  function GetItem(index: integer):Integer;
  procedure SetItem(index: integer; value: Integer);
  function GetCount: integer;
  function GetRealSize: integer;
protected
public
  constructor Create(InitialSize,ReAllocSize:integer);virtual;
  destructor Destroy; override;
  procedure Clear;
  procedure Add(value:Integer);
  procedure Delete(index: integer);
  procedure Insert(index: integer; value: Integer);
  function Search(value: Integer): integer;
  procedure CopyTo(var IL: TIntegerList);
  property Item[i:integer]:Integer read GetItem write SetItem;default;
  property Count: integer read GetCount;
  property Size: integer read FSize;
  property RealSize: integer read GetRealSize;
end;

implementation

//-----------------  TIntegerList ------------------------------
constructor TIntegerList.Create(InitialSize,ReAllocSize:integer);
begin
  if ReAllocSize = 0 then FReAllocSize := $10 else FReAllocSize := ReAllocSize;
  if InitialSize = 0 then FInitialSize := $10 else FInitialSize := InitialSize;
  FSize := FInitialSize;
  GetMem(FPointer,SizeOf(Integer)*FSize);
  FCount := -1;
end;

destructor TIntegerList.Destroy;
begin
  FreeMem(FPointer);
  inherited Destroy;
end;

procedure TIntegerList.Clear;
begin
  FreeMem(FPointer);
  FSize := FInitialSize;
  GetMem(FPointer,SizeOf(Integer)*FSize);
  FCount := -1;
end;

procedure TIntegerList.Add(value:Integer);
begin
  Inc(FCount);
  if FCount > FSize-1 then begin
    Inc(FSize,FReAllocSize);
    ReAllocMem(FPointer,SizeOf(Integer)*FSize);
  end;
  FPointer^[FCount] := value;
end;

procedure TIntegerList.Delete(index: integer);
begin
  if (index > FCount) or (index < 0) then Exit;
  if index = FCount then begin
    Dec(FCount);
    Exit;
  end;
  Move(FPointer^[index+1],FPointer^[index],
             SizeOf(Integer)*(FCount-index));
  Dec(FCount);
end;

procedure TIntegerList.Insert(index: integer; value: Integer);
begin
  if (index > FCount) or (index < 0) then Exit;
  if FCount+1 > FSize-1 then begin
    Inc(FSize,FReAllocSize);
    ReAllocMem(FPointer,SizeOf(Integer)*FSize);
  end;
  Move(FPointer^[index],FPointer^[index+1],
             SizeOf(Integer)*(FCount-index+1));
  FPointer^[index] := value;
  Inc(FCount);
end;

function TIntegerList.GetItem(index: integer):Integer;
begin
  if (index > FCount) or (index < 0) then
    result := 0
  else
    result := FPointer^[index];
end;

procedure TIntegerList.SetItem(index: integer; value: Integer);
begin
  if index > FSize-1 then begin
    repeat
      Inc(FSize,FReAllocSize);
    until  index < FSize-1;
    ReAllocMem(FPointer,SizeOf(Integer)*FSize);
  end;
  FPointer^[index] := value;
  if FCount < index then FCount := index;
end;

function TIntegerList.GetCount: integer;
begin
  result := FCount+1;
end;

function TIntegerList.GetRealSize: integer;
begin
  result := FSize;
end;

function TIntegerList.Search(value: Integer): integer;
var
  i: integer;
begin
  for i := 0 to FCount do
    if FPointer^[i] = value then begin
      result := i;
      Exit;
    end;
  result := -1;
end;

procedure TIntegerList.CopyTo(var IL: TIntegerList);
var
  i: integer;
begin
  IL.Clear;
  for i := 0 to FCount do
    IL[i] := FPointer^[i];
end;

end.

これらのコードには、 Win32 のＡＰＩを一つも使っていないので詳しい説明は不要だろうが、少しだけ説明する。整数リストを保持するメモリは、コンストラクタで private 部の FPointer に GetMem( ) で確保する。デストラクタでは、このメモリを解放する。 Clear メソッドでは、一度解放してから、再び新たに確保する。Add メソッドでは、配列の最後尾に数値を追加する。そのときメモリが足りなくなったら ReAllocMem( ) で拡張する。Delete メソッドは、配列の中の一つの要素を取り除く。除かれた要素以降の要素を Move( ) で一つ前方へ移す。 Insert メソッドは、これとは反対に要素を一つ挿入する。 Seach メソッドは、保持している整数配列から value の値と等しい要素のインデックスを返す。見つからなかったら－１を返す。配列のインデックスは０から始まる。他のメソッドやプロパティーはコードを見れば容易に理解できるだろう。 Main.pas では、ＲＡＤ環境で TIntegerList クラスのオブジェクトをテストしている。右図に、リストボックスとボタンを６個配置した様子を示す。以下に全リストを示す。

unit Main;

interface

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

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Button6: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

var
  IL: TIntegerList;
  SI: array[0..300] of integer;

procedure TForm1.FormCreate(Sender: TObject);
begin
  IL := TIntegerList.Create($10,$10);
  Randomize;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  IL.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i,j: integer;
begin
  IL.Clear;
  ListBox1.Items.Clear;
  for i := 0 to 300 do begin
    j := Random(100000000)-50000000;
    SI[i] := j;
    IL.Add(j);
  end;
  for i := 0 to IL.Count-1 do begin
    ListBox1.Items.Add(IntToStr(i)+' : '+IntToStr(SI[i])+
                       ' -> '+ IntToStr(IL[i]));
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  i, j: integer;
begin
  IL.Clear;
  ListBox1.Items.Clear;
  for i := 0 to 10 do begin
    j := Random(100000000)-50000000;
    IL.Add(j);
  end;
  for i := 0 to IL.Count-1 do begin
    ListBox1.Items.Add(IntToStr(i)+' : '+ IntToStr(IL[i]));
  end;
  IL.Delete(IL.Search(IL[5]));
  ListBox1.Items.Add(' ');
  for i := 0 to IL.Count-1 do begin
    ListBox1.Items.Add(IntToStr(i)+' : '+ IntToStr(IL[i]));
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  i, j: integer;
begin
  IL.Clear;
  ListBox1.Items.Clear;
  for i := 0 to 10 do begin
    j := Random(100000000)-50000000;
    IL.Add(j);
  end;
  for i := 0 to IL.Count-1 do begin
    ListBox1.Items.Add(IntToStr(i)+' : '+ IntToStr(IL[i]));
  end;
  IL.Insert(5,555555);
  ListBox1.Items.Add(' ');
  for i := 0 to IL.Count-1 do begin
    ListBox1.Items.Add(IntToStr(i)+' : '+ IntToStr(IL[i]));
  end;
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  i, j: integer;
begin
  IL.Clear;
  ListBox1.Items.Clear;
  for i := 0 to 10 do begin
    j := Random(100000000)-50000000;
    IL.Add(j);
  end;
  for i := 0 to IL.Count-1 do begin
    ListBox1.Items.Add(IntToStr(i)+' : '+ IntToStr(IL[i]));
  end;
  IL[7] := 777777;
  ListBox1.Items.Add(' ');
  for i := 0 to IL.Count-1 do begin
    ListBox1.Items.Add(IntToStr(i)+' : '+ IntToStr(IL[i]));
  end;
end;

procedure TForm1.Button5Click(Sender: TObject);
var
  i: integer;
  ILL: TIntegerList;
begin
  IL.Clear;
  ILL := TIntegerList.Create(0,0);
  ListBox1.Items.Clear;
  for i := 0 to 100 do
    IL[i] := Random(100000000)-50000000;
  IL.CopyTo(ILL);
  for i := 0 to ILL.Count-1 do
    ListBox1.Items.Add(IntToStr(i)+' : '+IntToStr(IL[i])+
                       ' -> '+ IntToStr(ILL[i]));
  ILL.Free;
end;

procedure TForm1.Button6Click(Sender: TObject);
var
  i,j: integer;
begin
  IL.Clear;
  ListBox1.Items.Clear;
  for i := 0 to 20 do begin
    j := Random(100000000)-50000000;
    SI[i] := j;
    IL.Add(j);
  end;
  for i := 0 to IL.Count-1 do begin
    ListBox1.Items.Add(IntToStr(i)+' : '+IntToStr(IL[i]));
  end;
  ListBox1.Items.Add(' ');
  j := IL.Search(SI[17]);
  if j = -1 then
    ListBox1.Items.Add('みつかりません')
  else
    ListBox1.Items.Add(IntToStr(j)+' : '+IntToStr(SI[17]));
end;

end.

FormCreate( ) で TIntegerList クラスのオブジェクト IL をつくり、FormDestroy( ) で解放している。 Button1Click( )では、３００個のランダムな整数を IL に格納し、整数配列に格納した値と比較している。このときの様子を上図に示した。 Button2Click( ) では五番目の要素の Delete メソッドのテスト、Button3Click( ) では五番目の要素への Insert メソッドのテスト、Button4Click( ) では七番目の要素の変更のテスト、Button5Click( ) では Copy メソッドのテスト、Button6Click( ) では Search メソッドをテストしている。

整数配列を動的に保持するクラスが手に入ったので、次節でいよいよ上記の仕様を持つ TMessageDispatcher を実装しよう。

４－６ TMessageDispatcher の実装

本節では前節で示した仕様を満たす TMessageDispatcher と TSubClass クラスを実装する。本節は、本稿の中で最もややこしい部分である。難解なのではなく、ふくざつなのである。TSubClass クラスは、本稿でつくる数多くのクラスのほとんどの上位クラスとなる重要なクラスである。このクラスは、メッセージの捕獲を自動的に行う。また、TMessageDispatcher は、TSubClass およびその派生クラスに対して特定のメッセージを配送し、適切なタイミングでオブジェクトを廃棄する。とにかく最初は、まず実装してしまい、それからコードを調べることにしよう。

４－６－１とにかく実装する

TMessageDispatcher と TSubClass クラスを実装し、テストするプログラムを作る。

まず、前節でつくった TIntegerList を UtilClass.pas に移そう。メモ帳などのテキストエディタに 0405RADIntegerList フォルダの Test.pas を読み込む。ここから、コピーと貼り付けを繰り返してコードエディタの UtilClass.pas に移すわけだ。さらに、TMessageDispatcher クラスと TSubClass クラスも実装する。 UtilClass.pas の全リストを以下に示す。

unit UtilClass;

interface

uses
  windows,
  messages;

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------

//------------------------------------------------------------
//                    Classes
//------------------------------------------------------------

//-----------------  TIntegerList ------------------------------
const
  MaxItem = 200000;

type
TIntegerArray = array[0..MaxItem] of Integer;
PIntegerArray = ^TIntegerArray;

TIntegerList = class(TObject)
private
  FPointer: PIntegerArray;
  FCount: integer;
  FSize: integer;
  FReAllocSize: integer;
  FInitialSize: integer;
  function GetItem(index: integer):Integer;
  procedure SetItem(index: integer; value: Integer);
  function GetCount: integer;
  function GetRealSize: integer;
protected
public
  constructor Create(InitialSize,ReAllocSize:integer);virtual;
  destructor Destroy; override;
  procedure Clear;
  procedure Add(value:Integer);
  procedure Delete(index: integer);
  procedure Insert(index: integer; value: Integer);
  function Search(value: Integer): integer;
  procedure CopyTo(var IL: TIntegerList);
  property Item[i:integer]:Integer read GetItem write SetItem;default;
  property Count: integer read GetCount;
  property Size: integer read FSize;
  property RealSize: integer read GetRealSize;
end;

//------------------ TMessageDispatcher ----------------------

TSubClass = class; // forward

TMessageDispatcher = class(TObject)
private
  FSList: TIntegerList;
  FParentList: TIntegerList;
  FParentProc: TIntegerList;
  FMessageList: TIntegerList;
  FMessageObject: TIntegerList;
  FCopyList: TIntegerList;
  FCopyList2: TIntegerList;
  FNeedCopy: Boolean;
  function GetCount:integer;
protected
  function IsNewParent(hWindow:HWND):Boolean;
  function IsParent(hWindow:HWND):Boolean;
  function GetParentProc(hWindow:HWND):TFNWndProc;
public
  constructor Create;
  destructor Destroy; override;
  procedure DefaultHandler(var Message);override;
  procedure Add(Obj:TSubClass);
  procedure Delete(Obj:TSubClass);
  procedure TrapMessage(Msg: UINT; Obj: TSubClass);
  property Count: integer read GetCount;
end;

//------------------ TSubClass -------------------------------
TSubClass = class(TObject)
private
  FParent: HWND;
  FData: integer;
protected
public
  constructor Create(hParent:HWND); virtual;
  destructor Destroy; override;
  property Parent: HWND read FParent;
  property Data : integer read FData write FData;
end;

var
  Dispatcher: TMessageDispatcher;

implementation

uses
  UtilFunc;

//------------------------------------------------------------
//                    Classes
//------------------------------------------------------------

//-----------------  TIntegerList ------------------------------
constructor TIntegerList.Create(InitialSize,ReAllocSize:integer);
begin
  if ReAllocSize = 0 then FReAllocSize := $10 else FReAllocSize := ReAllocSize;
  if InitialSize = 0 then FInitialSize := $10 else FInitialSize := InitialSize;
  FSize := FInitialSize;
  GetMem(FPointer,SizeOf(Integer)*FSize);
  FCount := -1;
end;

destructor TIntegerList.Destroy;
begin
  FreeMem(FPointer);
  inherited Destroy;
end;

procedure TIntegerList.Clear;
begin
  FreeMem(FPointer);
  FSize := FInitialSize;
  GetMem(FPointer,SizeOf(Integer)*FSize);
  FCount := -1;
end;

procedure TIntegerList.Add(value:Integer);
begin
  Inc(FCount);
  if FCount > FSize-1 then begin
    Inc(FSize,FReAllocSize);
    ReAllocMem(FPointer,SizeOf(Integer)*FSize);
  end;
  FPointer^[FCount] := value;
end;

procedure TIntegerList.Delete(index: integer);
begin
  if (index > FCount) or (index < 0) then Exit;
  if index = FCount then begin
    Dec(FCount);
    Exit;
  end;
  Move(FPointer^[index+1],FPointer^[index],
             SizeOf(Integer)*(FCount-index));
  Dec(FCount);
end;

procedure TIntegerList.Insert(index: integer; value: Integer);
begin
  if (index > FCount) or (index < 0) then Exit;
  if FCount+1 > FSize-1 then begin
    Inc(FSize,FReAllocSize);
    ReAllocMem(FPointer,SizeOf(Integer)*FSize);
  end;
  Move(FPointer^[index],FPointer^[index+1],
             SizeOf(Integer)*(FCount-index+1));
  FPointer^[index] := value;
  Inc(FCount);
end;

function TIntegerList.GetItem(index: integer):Integer;
begin
  if (index > FCount) or (index < 0) then
    result := 0
  else
    result := FPointer^[index];
end;

procedure TIntegerList.SetItem(index: integer; value: Integer);
begin
  if index > FSize-1 then begin
    repeat
      Inc(FSize,FReAllocSize);
    until  index < FSize-1;
    ReAllocMem(FPointer,SizeOf(Integer)*FSize);
  end;
  FPointer^[index] := value;
  if FCount < index then FCount := index;
end;

function TIntegerList.GetCount: integer;
begin
  result := FCount+1;
end;

function TIntegerList.GetRealSize: integer;
begin
  result := FSize;
end;

function TIntegerList.Search(value: Integer): integer;
var
  i: integer;
begin
  for i := 0 to FCount do
    if FPointer^[i] = value then begin
      result := i;
      Exit;
    end;
  result := -1;
end;

procedure TIntegerList.CopyTo(var IL: TIntegerList);
var
  i: integer;
begin
  IL.Clear;
  for i := 0 to FCount do
    IL[i] := FPointer^[i];
end;

//------------------ TMessageDispatcher ----------------------
function SubClassProc(hParent: HWND; Msg: UINT;
                       wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
  OriginalProc: TFNWndProc;
begin

  result := 0;
  if not Dispatcher.IsParent(hParent) then Exit;

  OriginalProc := Dispatcher.GetParentProc(hParent);

  result := CallWindowProc(OriginalProc,hParent,Msg,wParam,lParam);

  AMsg.Msg := Msg;
  AMsg.WParam := wParam;
  AMsg.LParam := lParam;
  AMsg.Result := hParent;

  case Msg of

    WM_DESTROY: begin
      SetWindowLong(hParent,GWL_WNDPROC,integer(OriginalProc));
      Dispatcher.Dispatch(AMsg);
    end;

  else
    Dispatcher.Dispatch(AMsg);

  end; // case

  if AMsg.Result <> 0 then result := AMsg.Result;

end;

constructor TMessageDispatcher.Create;
begin
  FSList := TIntegerList.Create($10,$10);
  FParentList := TIntegerList.Create($10,$10);
  FParentProc := TIntegerList.Create($10,$10);
  FMessageList := TIntegerList.Create($10,$10);
  FMessageObject := TIntegerList.Create($10,$10);
  FCopyList := TIntegerList.Create($10,$10);
  FCopyList2 := TIntegerList.Create($10,$10);
  FNeedCopy := false;
end;

destructor TMessageDispatcher.Destroy;
begin
  FNeedCopy := false;
  FSList.Free;
  FParentList.Free;
  FParentProc.Free;
  FMessageList.Free;
  FMessageObject.Free;
  FCopyList.Free;
  FCopyList2.Free;
  inherited Destroy;
end;

procedure TMessageDispatcher.DefaultHandler(var Message);
var
  AMsg: TMessage;
  hParent: HWND;
  i: integer;
  SO: TSubClass;
begin
  AMsg := TMessage(Message);

  hParent := AMsg.Result;
  TMessage(Message).result := 0; // default return result
  AMsg.Result := 0;              // default object return

  if AMsg.Msg = WM_DESTROY then begin
    for i := FSList.Count-1 downto 0 do begin
      SO := TSubClass(FSList[i]);
      if Assigned(SO) then
        if (SO.Parent = hParent) then begin
          FSList.Delete(i);
          SO.Free;  //SO := nil;
        end;
    end;
    FParentProc.Delete(FParentList.Search(hParent));    
    FParentList.Delete(FParentList.Search(hParent));
    exit;
  end;

  if FMessageList.Search(AMsg.Msg) = -1 then
    exit
  else begin
    if FNeedCopy then begin
      FMessageList.CopyTo(FCopyList);
      FMessageObject.CopyTo(FCopyList2);
      FNeedCopy := false;
    end;
    for i := 0 to FCopyList.Count-1 do
      if DWORD(FCopyList[i]) = AMsg.Msg then begin
        SO := TSubClass(FCopyList2[i]);
        if Assigned(SO) then
          if (SO.Parent = hParent) then begin
            SO.Dispatch(AMsg);
            if AMsg.Result <> 0 then begin
              TMessage(Message).result := AMsg.Result;
             exit;
            end;
          end;
      end;
  end;
end;

procedure TMessageDispatcher.TrapMessage(Msg: UINT; Obj: TSubClass);
begin
  FMessageList.Add(Msg);
  FMessageObject.Add(integer(Obj));
  FNeedCopy := true;
end;

function TMessageDispatcher.IsNewParent(hWindow:HWND):Boolean;
begin
  result := true;
  if FParentList.Count < 1 then Exit;
  if FParentList.Search(hWindow) > -1 then result := false;
end;

function TMessageDispatcher.IsParent(hWindow:HWND):Boolean;
begin
  result := false;
  if FParentList.Count < 1 then Exit;
  if FParentList.Search(hWindow) = -1 then
    result := false
  else
    result := true;
end;

function TMessageDispatcher.GetParentProc(hWindow:HWND):TFNWndProc;
begin
  result := TFNWndProc(FParentProc[FParentList.Search(hWindow)]);
end;

procedure TMessageDispatcher.Add(Obj:TSubClass);
var
  OriginalProc: integer;
begin
  FSList.Add(Integer(Obj));

  if IsNewParent(Obj.Parent) then begin
    FParentList.Add(Obj.Parent);
    OriginalProc := GetWindowLong(Obj.Parent,GWL_WNDPROC);
    FParentProc.Add(OriginalProc);
    SetWindowLong(Obj.Parent,GWL_WNDPROC,integer(@SubClassProc));
  end;
end;

procedure TMessageDispatcher.Delete(Obj:TSubClass);
var
  i: integer;
begin
  FSList.Delete(FSList.Search(Integer(Obj)));
  for i := FMessageObject.Count-1 downto 0 do
    if FMessageObject[i] = integer(Obj) then begin
      FMessageObject.Delete(i);  // UnTrap Message
      FMessageList.Delete(i);
    end;
  FNeedCopy := true;
end;

function TMessageDispatcher.GetCount:integer;
begin
  result := FSList.Count;
end;

//------------------ TSubClass -------------------------------
constructor TSubClass.Create(hParent:HWND);
begin
  if not Assigned(Dispatcher) then Dispatcher := TMessageDispatcher.Create;
  FParent := hParent;
  Dispatcher.Add(self);
end;

destructor TSubClass.Destroy;
begin
  Dispatcher.Delete(self);
  inherited Destroy;
end;

initialization

finalization
  Dispatcher.Free;

end.

UtilClass.pas のコードを調べるのは後回しにして、TSubClass から派生するように TSpeedBtn クラスを少し変更しよう。 Test.pas の全リストを以下に示す。

unit Test;

interface

uses
  windows,
  messages,
  UtilFunc,
  UtilClass;

type

TSpeedBtn = class(TSubClass)
private
  FColor: COLORREF;
  FRect: TRect;
public
  constructor Create(hParent: HWND); override;
  destructor Destroy; override;
  procedure DefaultHandler(var Message); override;
  property Rect: TRect read FRect write FRect;
end;

implementation

constructor TSpeedBtn.Create(hParent: HWND);
begin
  inherited Create(hParent);
  FColor := clrBlue;
  Dispatcher.TrapMessage(WM_PAINT,self);
  Dispatcher.TrapMessage(WM_LBUTTONDOWN,self);
end;

destructor TSpeedBtn.Destroy;
begin
  InvalidateRect(Parent,@FRect,true);
  inherited Destroy;
end;

procedure TSpeedBtn.DefaultHandler(var Message);
var
  Msg: TMessage;
  hBr: HBRUSH;
  DC: HDC;
  p: TPoint;
begin
  Msg := TMessage(Message);
  case Msg.Msg of
    WM_PAINT:begin
      hBr := CreateSolidBrush(FColor);
      DC := GetDC(Parent);
        FillRect(DC,FRect,hBr);
        DeleteObject(hBr);
        SetBkMode(DC,TRANSPARENT);
        SetTextColor(DC,clrWhite);
        DrawText(DC,'SpeedBtn',8,FRect,DT_CENTER or
                                  DT_SINGLELINE or DT_VCENTER);
      ReleaseDC(Parent,DC);
    end;
    WM_LBUTTONDOWN:begin
      p.x := Msg.LParamLo;
      p.y := Msg.LParamHi;
      if PtInRect(FRect,p) then begin
        if FColor = clrBlue then FColor := clrRed else FColor := clrBlue;
        InvalidateRect(Parent,@FRect,true);
      end;
    end;
  end; // case
end;

end.

である。コンストラクタの実装部は以下のようになっている。

ここでは、最初に継承メソッドを呼び出して TSubClass のコンストラクタのコードを実行する。後で説明するように、TSubClass のコンストラクタでは、TMessageDispatcher のただ一つのインスタンス Dispatcher を作成している。継承メソッドを呼び出した後で、FColor フィールドを初期化し、Dispatcher のメソッド TrapMessage( ) を二度呼び出している。このメソッドについても後で説明するが、やっていることは、捕捉したいメッセージとともに自分自身のインスタンス参照 self を Dispatcher に登録し、このメッセージを配送してくれるように依頼しているのである。これで、hParent パラメータで示される親ウィンドウを自動的にサブクラス化して、二つのメッセージがこのインスタンスに届けられるというわけである。
この TSpeedBtn のインスタンスを二つつくって、テストする SubClass02.dpr の全リストを以下に示す。

program SubClass02;

uses
  windows,
  messages,
  UtilFunc in 'UtilFunc.pas',
  Test in 'Test.pas',
  UtilClass in 'UtilClass.pas';

//------------------------------------------------------------
//             Global Types, Constants and Variables
//------------------------------------------------------------
var
  Clr: COLORREF;

  SP1,SP2: TSpeedBtn;

//------------------------------------------------------------
//             Event Handlers
//------------------------------------------------------------
procedure OnCreate(var Msg: TMessage);
var
  hWindow: HWND;
begin
  hWindow := Msg.Msg;
  Clr := clrBtnFace;
  MakeInitMenu(hWindow);
  ChangeWindowSize(hWindow,400,300);
  CenterWindow(hWindow);

  SP1 := TSpeedBtn.Create(hWindow);
  SP1.Rect := SetDim(50,50,200,100);

  SP2 := TSpeedBtn.Create(hWindow);
  SP2.Rect := SetDim(50,120,200,170);

end;

procedure OnTest(hWindow: HWND);
begin
  MessageBeep($FFFFFFFF);
end;

procedure OnCommand(var Msg: TMessage);
begin
  InitMenuCommand(Msg,OnTest);
end;

procedure OnEraseBkgnd(var Msg: TMessage);
begin
  Msg.Result := EraseBkGnd(Msg.Msg,Clr,Msg.WParam);
end;

procedure OnDestroy(var Msg: TMessage);
begin
  PostQuitMessage(0);
end;

//------------------------------------------------------------
//             Main Window Procedure
//------------------------------------------------------------
function MainWndProc(hWindow: HWND; Msg: UINT; WParam: WPARAM;
                      LParam: LPARAM): LRESULT; stdcall;
var
  AMsg: TMessage;
begin
  Result := 0;

  AMsg.Msg := hWindow;
  AMsg.WParam := WParam;
  AMsg.LParam := LParam;
  AMsg.Result := 0;

  case Msg of

//-------------  WM_CREATE  -----------------------------------

     WM_CREATE: OnCreate(AMsg);

//-------------  WM_COMMAND  ----------------------------------

     WM_COMMAND: OnCommand(AMsg);

//-------------  WM_ERASEBKGND  -------------------------------

     WM_ERASEBKGND: begin
       OnEraseBkgnd(AMsg);
       result := AMsg.Result;
     end;

//-------------  WM_DESTROY  ----------------------------------

     WM_DESTROY: OnDestroy(AMsg);

//-------- そのほかのメッセージの処理 ------
  else begin
    result := DefWindowProc( hWindow, Msg, wParam, lParam );
    end;

  end; // case
end;

//------------------------------------------------------------
//             Main Procedure
//------------------------------------------------------------
begin

  MakeMainWindow(@MainWndProc);

  Halt(MessageLoopNormal);

end.

SubClass02.dpr が Skeleton01.dpr と異なる主な点は、 uses 節と、OnCreate( ) ハンドラで TSpeedBtn のインスタンスを二つ作成していることだ。実行すると右図のように SubClass01.dpr と全く同じ動作をすることが確かめられる。ご覧のように、プロジェクトファイルのコードでは、インスタンスを生成する以外のメッセージ処理のコードは完全になくなっている。この時点で TSpeedBtn は、メッセージを自前で捕獲し処理する能力を獲得したと言えるだろう。また、自身を解放することもできる。これは Dispatcher が適切なタイミングで行ってくれるのだ。

４－６－２実装コードを調べる

UtilClass.pas の TMessageDispatcher クラスの宣言を以下に示す。

private 部の TIntegerList 型のフィールド変数 FSList は、TSubClass 及びその派生クラスのインスタンス参照のリストを保持する。TSubClass のコンストラクタのコードを見てみよう。

ここでは、UtilClass.pas の implementation 予約語の直ぐ上に宣言されている TMessageDispatcher 型の変数 Dispatcher が既に作成されているかどうか調べ、もし作成されていなければ作成する。これにより、TSubClass の最初のインスタンスだけが Dispatcher を作成する。つぎに、親のハンドルを FParent に格納し、そのあと Dispatcher の Add メソッドを使って自分自身を登録している。

Add メソッドでは、FSList にオブジェクト参照を追加してから、このオブジェクトの親ウィンドウがすでに登録されている親か、登録されていない新しい親かを IsNewParent( ) メソッドを使って調べ、新しい親ならサブクラス化を実行する。 if....end; の中のコードを見てみよう。ここは、サブクラス化を行う重要な部分である。

の手順でサブクラス化する。GetWindowLong( ) と SetWindowLong( ) ＡＰＩはすでに説明した。３．のコードについて考えよう。SubClass01 では、サブクラス化する以前のもともとのウィンドウ関数をグローバル変数に保持した。このときは、親がメイウィンドウだけであることがあらかじめ分かっていたからである。 TSubClass クラスの派生クラスは、メインウィンドウの上に作られるかもしれないし、パネルなどのコンテナの上につくられるかもしれないし、ダイアログなどのポップアップウィンドウの上に作られるかもしれない。要するに、あらかじめ親の数と種類を予測できないので、グローバル変数にもとのウィンドウ関数のアドレスを保持することができないのである。もとのウィンドウ関数のアドレスが必要なのは、サブクラス化したウィンドウ関数内で CallWindowProc( ) によりメッセージを渡す場面である。そこでは、メッセージのほかに参照できるものとしては、親ウィンドウのハンドルだけである。したがって、親ウィンドウのハンドルだけを知って、もとのウィンドウ関数のアドレスにアクセスできなければならない。そこで、Add メソッドで親のウィンドウハンドルを FParentList に追加するのと同じタイミングで OriginalProc も FParentProc に追加する。 GetParentProc( ) メソッドは、親のハンドルからサブクラス化する前のウィンドウ関数を取り出す。

これによって、ウィンドウハンドルからもともとのウィンドウ関数を取り出すことができた。

以上で、サブクラス化が完了したので、捕捉したいメッセージとその配送先を登録する TrapMessage( ) メソッドを見てみよう。

ここでは、private 部のフィールド変数に追加しているだけだ。そして、FNeedCopy フラグを true にして、コピーリストも更新する。

メッセージの流れを追跡しよう。全てのメッセージは SubClassProc から入ってくる。

もとのウィンドウ関数を CallWindowProc( ) をつかって実行した後で、TMessage 型のレコード AMsg を組み立てる。その際、 Result フィールドにはウィンドウハンドルを格納する。そして、WM_DESTROY 以外のメッセージはすべて Dispatcher に送り込む。 WM_DESTROY のときは、サブクラス化を解除してから Dispatcher に送る。 Dispatcher は、送られたメッセージを DefaultHandler( ) で処理している。

ここでは、最初に Result フィールドからウィンドウハンドルを取りだし、代わりにデフォルトの値ゼロを格納する。次に、メッセージが WM_DESTROY のときは、オブジェクトリストを逆にたどって、親ハンドルが一致するオブジェクトを探し出して削除している。そして、親ウィンドウ関数リストや親ハンドルリストからも削除している。 WM_DESTROY メッセージ以外のメッセージは、登録されているメッセージかどうか調べて、登録されていなければ何もしない。一つでも登録されていれば、 FNeedCopy フラグが true ならば、メッセージリストとオブジェクトリストをコピーする。そして、そのコピーを使って、メッセージを要求しているオブジェクトを for ループにより探して、見つかったら Dispatch メソッドを使ってメッセージを送る。デフォルトのゼロ以外の Result が返ってきたら、SubClassProc に変数渡しで送り返す。 SubClassProc では、この値を戻り値にしてシステムに返す。

オブジェクトの検索の際、なぜコピーリストを使うのか疑問に思われるかもしれない。これは、オブジェクトがメッセージを受け取ったときに行う処理のなかで、他のオブジェクトや自分自身を削除したり、あるいは、新しいオブジェクトを追加するかもしれないからである。このとき、メッセージを受け取った時点で検索をはじめたときの FMessageList と FMessageObject は、Delete や TrapMessage メソッドにより変化させられる。これでは、検索のループがめちゃくちゃになるので、メッセージを送るための検索中は変動しないようにコピーリストを使用するのである。このことは非常に重要であり、コピーを使うことにより、後につくるスピードボタンなどのクリックイベントで自分自身を消去する事さえできるようになる。 ＶＣＬのオブジェクトは、自分のイベントハンドラで自分を解放することができる。これは、実装するプログラマの見地に立つと、イベントハンドラの処理としては最も厳しい処理の一つである。

TMessageDispatcher の唯一のインスタンス Dispatcher は、UtilClass.pas の終了処理部で削除する。

Dispatcher の宣言は interface 部にあるので、このユニットを uses する全てのユニットから参照できる。

以上で、TMessageDispatcher と TSubClass の実装コードの説明は終わりである。 TSubClass のインスタンスは Dispatcher をつくり自分自身を登録する。さらにその派生クラスである TSpeedBtn のコンストラクタに見られるように Dispatcher の TrapMessage メソッドを使って特定のメッセージを自分に送ってくれるよう依頼する。Dispacther は、TSubClass のインスタンス参照やその親のハンドルやウィンドウ関数のリスト、捕捉するメッセージのリストなどを保持して、SubClassProc から送られたメッセージを適切なインスタンスに配達する、という図式が理解出来ただろう。

４－７まとめ

本章では、Win32 システムにおけるウィンドウの雛形であるウィンドウクラスの情報やウィンドウ自体の情報を取得し、さらに変更する方法について調べた。また、サブクラス化やフック関数のインストールによってウィンドウ関数に送られてくるメッセージを「盗み見る」方法を、簡単なＲＡＤプログラムで試してみた。スピードボタンのようなウィンドウではないオブジェクトが独自に親ウィンドウのメッセージを処理するために、サブクラス化の手法を使って TMessageDispatcher クラスと TSubClass クラスを実装した。前章でつくった TSpeedBtn を TSubClass の派生クラスとして実装し直し、メインウィンドウのウィンドウ関数に依存しないでメッセージを取得し、処理する事ができることを確かめた。

TSubClass は、本稿でつくるクラスのうちの大部分の上位クラスとなる重要なクラスである。 TSubClass の派生クラスは、Dispatcher の TrapMessage メソッドを使って、親ウィンドウから特定のメッセージを独自に取得するメカニズムを持っている。