TFindDialog とスタイル

ソースはこちら(GitHub)

TFindDialog に TControl 派生コントロールを乗せる必要があり、TFindDialogEx を実装しました。
TFindDialog に限らず TCommonDialog を継承するダイアログは、Windows のコモンダイアログのラッパーになっています。
そのため、VCL のコントロールを乗せるのは、少しテクニックが必要です。

具体的には、下記の様に TPanel などのコンテナに乗せてやる必要があるのです。

// Vcl.ExtDlg の TOpenTextFileDialog から引用
constructor TOpenTextFileDialog.Create(AOwner: TComponent);
var
  I: Integer;
begin
  (省略)
 
  FPanel := TPanel.Create(Self);
  with FPanel do
  begin
    (省略)
 
    with FLabel do
    begin
      (省略)
      Parent := FPanel;
    end;
 
    FComboBox := TComboBox.Create(Self);
    with FComboBox do
    begin
      (省略)
      Parent := FPanel;
    end;
  end;
end;

もし、TPanel に乗せないとどうなるかというと、フォーカスを受け取れなくなり、マウス・キーボードの操作が効かなくなります。

ということで、まねして TFindDialogEx のコンストラクタでも TPanel のインスタンスを生成します。

constructor TFindDialogEx.Create(iOwner: TComponent);
begin
  inherited;
 
  FPanel := TPanel.Create(Self);
  with FPanel do begin
    BevelInner := bvNone;
    BevelOuter := bvNone;
    StyleElements := [];
    FullRepaint := False;
    TabOrder := 0;
    TabStop := True;
    Color := clBtnFace;
  end;
end;

ここで重要なのは StyleElements です。
Windows のコモンダイアログに乗るので Style による描画は必要ありません。
もし、StyleElements に何もしていないと……



上図のように周りから浮いてしまいます。
次に、ダイアログに乗せるコントロールを追加するメソッドを定義します。

// iControl を FPanel の子供に設定する
procedure TFindDialogEx.AddControl(const iControl: TControl);
begin
  if (FControl <> nil) then
    FControl.Parent := nil;
 
  FControl := iControl;
 
  if (FControl <> nil) then begin
    FControl.Parent := FPanel;
 
    ListupControl(
      FControl,
      procedure (const iControl: TControl)
      begin
        iControl.StyleElements := [];
      end
    );
  end;
end;
 
// ListUpControl は全てのコントロールを列挙する
type
  TListupCallback = reference to procedure (const iControl: TControl);
      
procedure TFindDialogEx.ListupControl(
  const iControl: TControl;
  const iCallback: TListupCallback);
var
  i: Integer;
begin
  if (iControl <> nil) then begin
    if (iControl is TWinControl) then
      with TWinControl(iControl) do
        for i := 0 to ControlCount - 1 do
          ListupControl(Controls[i], iCallback);
 
    iCallback(iControl);
  end;
end;

このように FPanel を Parent に設定しています。
また、FPanel と同様に StyleElements も [] として設定しています。

ListupControl では reference to を使って、無名メソッドを呼び出すようにしています。
これによって、Listup した Control を簡単に処理できます。

次に、ダイアログに FPanel を乗せる処理です。
コモンダイアログは、WM_INITDIALOG メッセージで、初期化処理をします。
TCommonDialog には WM_INITDIALOG メッセージを受信したときに呼ばれる DoShow メソッドがあります。
そこで、これを override して、初期化処理をします。

type
  TFindDialogEx = class(TFindDialog)
  (略)
  protected
    procedure DoShow; override;
  (略)
  end;
 
implementation
 
procedure TFindDialogEx.DoShow;
var
  WndRect: TRect;
  tmpRect: TRect;
begin
  inherited;
 
  GetWindowRect(Handle, WndRect); // Screen 座標の位置。NoClient エリアも含む
  GetClientRect(Handle, tmpRect); // Window 座標の位置。Client エリアのみ
 
  if (FControl <> nil) then begin
    FPanel.ParentWindow := Handle; // Dialog を親に設定
 
    // パネルのサイズを計算
    FPanel.ClientHeight := FControl.Height;
    FPanel.SetBounds(
      0,
      tmpRect.Height - 10, // 10 pixel 位上だと見栄えが良い
      tmpRect.Width,
      FControl.Height);
 
    // パネルの高さ分、ダイアログのウィンドウを伸ばす
    MoveWindow(
      Handle,
      WndRect.Left,
      WndRect.Top,
      WndRect.Width,
      WndRect.Height + FPanel.Height, // FPanel の高さ分伸ばす
      True);
  end;
end;

では、ここまでで動かしてみると……



なんと、コントロールが表示されていません。
ちなみに、マウスをオーバーしたり、Alt キーを押すと表示されます。
これは、Windows のコモンダイアログのメッセージ処理が上手く流れてこないためです。
なので、コモンダイアログの WM_ERASEBKGND メッセージで、コントロールを再描画してやる必要があります。

procedure TFindDialogEx.WMEraseBkGnd(var ioMsg: TWMEraseBkGnd);
begin
  inherited;
 
  ListupControl(
    FControl,
    procedure (const iControl: TControl)
    begin
      iControl.Repaint; // 再描画させる
    end
  );
end;

では、これでもう一度表示させてみると……



上手く表示されました。
で、事はこれで終わりかと思いきや、とんでもないバグが潜んでいたのです。

TFindDialog は他のダイアログと違い、モードレスなダイアログです。
つまり、ダイアログを表示している最中に、ユーザーは任意のフォームを操作できます。
そのため、TFindDialog を出したまま、スタイルを変更することもできるのです。

もし、そうするとどうなるかというと、Execute を呼び出してもダイアログは表示されなくなります。

これは、何故かと言うと下記のコードが Execute に記述されているからです。

function TFindDialog.Execute(ParentWnd: HWND): Boolean;
var
  Option: TFindOption;
begin
  if FFindHandle <> 0 then // 0 かどうかで判断している
  begin
    // 0 じゃなかったら既に表示されていると判断して
    // ウィンドウを前に持ってくる処理を走らせる
    // しかし！ ウィンドウハンドルが無効だった場合、何も起きない！
    BringWindowToTop(FFindHandle);
    Result := True;
  end else
  begin
    (略)
  end;
end;

Style が変更されるとウィンドウは RecreateWnd を使って再生成されます。
そのため、FFindHandle は 0 ではありませんが、無効なウィンドウハンドルになっています。
これによって、Execute を呼び出しても何も起きないのです。

そこで、この不具合を取り除くために拡張 RTTI を使って、FFindHandle を 0 にします。

function TFindDialogEx.Execute(ParentWnd: HWND): Boolean;
var
  TId: DWORD;
  Context: TRttiContext;
  Field: TRttiField;
  Obj: TObject;
begin
  // 無効なウィンドウハンドルでは 0 が返る
  TId := GetWindowThreadProcessId(Handle);
  if (TId = 0) then begin
    Context := TRttiContext.Create;
    try
      try
        Field := Context.GetType(Self.ClassType).GetField('FFindHandle');
        if (Field <> nil) then
          Field.SetValue(Self, 0); // FFindHandle を 0 に
 
        Field := Context.GetType(Self.ClassType).GetField('FRedirector');
        if (Field <> nil) then begin
          Obj := Field.GetValue(Self).AsObject;
          if (Obj <> nil) then
            Obj.Free; // FRedirector を解放
        end;
      except
      end;
    finally
      Context.Free;
    end;
  end;
 
  Result := inherited;
end;

FFindHandle だけではなく FRedirector というコントロールも破棄する必要があるので、それも破棄しています。
このように拡張 RTTI を使うと private として隠蔽されていた変数やメソッドまで呼べてしまいます。

Java を知っている方にはおなじみ？のリフレクションと同じ機能です。
静的型付けのコンパイル型言語で、同じ事ができるとは驚きです。

非常に強力なので、注意が必要です。

拡張 RTTI については、第２３回デベロッパーキャンプの福士さんの資料が詳しいです。

これで、完全に動作するようになりました。

Delphi でコモンダイアログをカスタマイズする方法があまり存在しないので、書いてみました。