Delphi 6 ローテクTips/フォームのタイトルバーにUnicodeを表示

ウムラウトのようなUnicode文字をフォームのタイトルバーに表示させましょうというページ。

参考サイト

実現方法

ちょっとややこしいですが難しいことはありません。
フォームのCaptionプロパティを無し（空文字）にしておき、まっさらな状態のタイトルバーに自前でDrawTextW APIを使ってUnicodeな文字を出力するだけです。

まずGetWindowDC APIでタイトルバーも含んだフォーム全体のデバイスコンテキストを取得し、あとはフォントを設定し透過モードで文字を出力するだけです。
難しいことはありませんが、フォームのスタイルによって文字列を出力する範囲が変わったりフォントの設定も変わるので少しややこしくなります。

//XPテーマが有効かどうかをテストするAPI。
function IsThemeActive: BOOL; stdcall; external 'uxtheme.dll';

procedure PaintCaption(sText: WideString; AForm: TForm); overload;
procedure PaintCaption(sText: WideString; AForm: TForm; bActive: Boolean); overload;

...

procedure PaintCaption(sText: WideString; AForm: TForm);
begin
PaintCaption(sText, AForm, (GetActiveWindow = AForm.Handle));
end;

procedure PaintCaption(sText: WideString; AForm: TForm; bActive: Boolean);
//UnicodeなテキストをAFormのタイトルバーに表示。
//http://eternalwindows.jp/graphics/repaint/repaint06.html
const
lci_ICONMARGIN = 2; //フレームとアイコンの間の幅。
lci_XPSIZEMARGIN = 2; //最小化・最大化ボタンの間の幅(XPスタイルは狭くなっているのでこの値を引く)
var
li_Style, li_StyleEx: LongInt;
l_Canvas: TCanvas;
lrc_TitleBar: TRect;
li_FrameWidth, li_ButtonWidth, li_TitleBarHeight: Integer;
l_NonClientMetrics: TNonClientMetrics;
lh_Font: HFONT;
begin
//タイトルバーがあるか。あればツールウィンドウか普通のタイトルバーかの判定のため。
li_Style := GetWindowLong(AForm.Handle, GWL_STYLE); //ウィンドウスタイル
li_StyleEx := GetWindowLong(AForm.Handle, GWL_EXSTYLE); //拡張ウィンドウスタイル

if ((li_Style and WS_CAPTION) = 0) then begin
//タイトルバーなし。
//タイトルバーがなければそもそも文字列を表示できない。
Exit;
end;
//タイトルバーあり。

//キャンバス作成。
l_Canvas := TCanvas.Create;
try
//フレームやタイトルバーも含めたフォーム全体のデバイスコンテキストをセット。
l_Canvas.Handle := GetWindowDC(AForm.Handle);

if ((li_StyleEx and WS_EX_TOOLWINDOW) <> 0) then begin
//ツールウィンドウ。
li_ButtonWidth    := GetSystemMetrics(SM_CXSMSIZE);
li_TitleBarHeight := GetSystemMetrics(SM_CYSMCAPTION);
end else begin
//普通のタイトルバー。
li_ButtonWidth    := GetSystemMetrics(SM_CXSIZE);
li_TitleBarHeight := GetSystemMetrics(SM_CYCAPTION);
end;
li_FrameWidth := GetSystemMetrics(SM_CXFRAME);

//文字列を表示する矩形をセット。
lrc_TitleBar.Left := li_FrameWidth;                      //アイコンのないとき。
lrc_TitleBar.Right := AForm.Width - li_FrameWidth; //ボタンのないとき。
lrc_TitleBar.Top := GetSystemMetrics(SM_CYFRAME);
lrc_TitleBar.Bottom := lrc_TitleBar.Top + li_TitleBarHeight;

//普通のタイトルバーかツールウィンドウか。
if ((li_StyleEx and WS_EX_TOOLWINDOW) <> 0) then begin
//ツールウィンドウ。
if (biSystemMenu in AForm.BorderIcons) then begin
//閉じるボタンあり。
Dec(lrc_TitleBar.Right, li_ButtonWidth);
end;
end else begin
//普通のタイトルバー。
if (biSystemMenu in AForm.BorderIcons) then begin
if (AForm.BorderStyle <> bsDialog) then begin
//アイコンあり。
Inc(lrc_TitleBar.Left, (lci_ICONMARGIN * 2) + GetSystemMetrics(SM_CXSMICON));
end;

//閉じるボタンあり。
Dec(lrc_TitleBar.Right, li_ButtonWidth);
if (biMinimize in AForm.BorderIcons) or (biMaximize in AForm.BorderIcons) then begin
//最小化・最大化ボタンもあり。
if (IsThemeActive) then begin
//XPスタイル。
//XPスタイルはボタン間の幅が詰まっているのでその分を引く。
//Vista以降で違う可能性もあり。
Dec(lrc_TitleBar.Right, (li_ButtonWidth - lci_XPSIZEMARGIN) * 2);
end else begin
//クラシックスタイル。
Dec(lrc_TitleBar.Right, li_ButtonWidth * 2);
end;
end;
end;
end;

with l_Canvas do begin
//フォントの設定
l_NonClientMetrics.cbSize := SizeOf(l_NonClientMetrics);
SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @l_NonClientMetrics, 0);
if ((li_StyleEx and WS_EX_TOOLWINDOW) <> 0) then begin
//ツールウィンドウ。
lh_Font := CreateFontIndirect(l_NonClientMetrics.lfSmCaptionFont);
end else begin
//普通のタイトルバー。
lh_Font := CreateFontIndirect(l_NonClientMetrics.lfCaptionFont);
end;
if (lh_Font <> 0) then begin
Font.Handle := lh_Font;
end else begin
Font.Style := Font.Style + [fsBold];
if not(IsThemeActive)
or ((li_StyleEx and WS_EX_TOOLWINDOW) <> 0)
then begin
//クラシックスタイルもしくはツールウィンドウ。
Font.Size := 9;
end else begin
//XPスタイルの普通のタイトルバー。
Font.Size := 10;
end;
end;
if (bActive) then begin
Font.Color := clCaptionText;
end else begin
Font.Color := clInActiveCaptionText;
end;

SetBkMode(Handle, TRANSPARENT);
DrawTextW(Handle, PWideChar(sText), -1, lrc_TitleBar, DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX or DT_END_ELLIPSIS);
DeleteObject(lh_Font);
end;
finally
ReleaseDC(AForm.Handle, l_Canvas.Handle);
l_Canvas.Free;
end;
end;

GetWindowDC APIで取得したデバイスコンテキストをTCanvasのHandleプロパティにセットしています。
こうすることでタイトルバーのフォントの設定をCanvasのFontプロパティで扱えるようになるので少し楽になります。

//キャンバスを作成。
l_Canvas := TCanvas.Create;
try
//フレームやタイトルバーも含んだフォーム全体のデバイスコンテキストをセット。
l_Canvas.Handle := GetWindowDC(AForm.Handle);

テキストを表示する矩形のセットでアイコンのあるなし、最小化ボタンや閉じるボタンのあるなし、普通のタイトルバーか小さいタイトルバー(ツールウィンドウ)かに対応させているのでちょっとややこしくなっています。

GetSystemMetrics(SM_CXSIZE)で取得したボタンの幅はボタンとボタンの間の隙間も含めた値になるようです。
ただ、XPスタイルの場合で最小化と最大化ボタンがあるタイトルバーの場合その値を単純に三倍した値を使うとテキスト表示矩形の右端とボタンとの間が空きすぎてしまいます。
これは最小化ボタンと最大化ボタンの間が詰まっているためだと思われます。
ということでそれぞれ2ピクセル分差し引いています。
このあたりのレイアウトは新しいOSが出るたびに細かい違いが出るのかもしれません。

const
lci_XPSIZEMARGIN = 2; //最小化・最大化ボタンの間の幅(XPスタイルは狭くなっているのでこの値を引く)

...

if (biMinimize in AForm.BorderIcons) or (biMaximize in AForm.BorderIcons) then begin
//最小化・最大化ボタンもあり。
if (IsThemeActive) then begin
//XPスタイル。
//XPスタイルはボタン間の幅が詰まっているのでその分を引く。
//Vista以降で違う可能性もあり。
Dec(lrc_TitleBar.Right, (li_SizeButton - lci_XPSIZEMARGIN) * 2);

フォントはSystemParametersInfo APIとCreateFontIndirect APIを使って取得します。
l_NonClientMetricsではタイトルバーのフォントの他にヒントやメニューのフォントの情報や最小化や閉じるボタンの幅や高さなどの情報も一括して取得できます。

//フォントの設定
l_NonClientMetrics.cbSize := SizeOf(l_NonClientMetrics);
SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @l_NonClientMetrics, 0);
if ((li_StyleEx and WS_EX_TOOLWINDOW) <> 0) then begin
//ツールウィンドウ。
lh_Font := CreateFontIndirect(l_NonClientMetrics.lfSmCaptionFont);
end else begin
//普通のタイトルバー。
lh_Font := CreateFontIndirect(l_NonClientMetrics.lfCaptionFont);
end;
if (lh_Font <> 0) then begin
Font.Handle := lh_Font;

文字列の出力はSetBkMode APIを使って背景モードを透過にします。
こうすることでタイトルバーのグラデーションを残したままで文字を出力することができます。
終わったらフォントを解放します。
この例では汎用手続きにしているのでフォントは逐一作成、解放するようにしていますが、クラスのprivate変数などに作成したフォントを持つようにすれば逐一作成、解放しなくて良いので効率的かも知れません。

DrawTextW APIのオプションに、文字列が矩形に収まらない場合に末尾を'...'にするDT_END_ELLIPSISオプションをつけています。

SetBkMode(Handle, TRANSPARENT);
DrawTextW(Handle, PWideChar(sText), -1, lrc_TitleBar, DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX or DT_END_ELLIPSIS);
DeleteObject(lh_Font);

上記のコードでタイトルバーにUnicodeな文字を出力できますが、参考サイトにもあるようにそれだけではうまくありません。
WM_NCACTIVEとWM_NCPAINTメッセージに応答するようにしないとなりません。

private
{ Private 宣言 }
F_sCaption: WideString; //タイトルバーに表示する文字列。

procedure WMNcActivate(var Msg: TMessage); message WM_NCACTIVATE;
procedure WMNcPaint (var Msg: TMessage); message WM_NCPAINT;

...

procedure TForm1.WMNcActivate(var Msg: TMessage);
begin
inherited;

PaintCaption(F_sCaption, Self, (Msg.WParam <> 0));
end;

procedure TForm1.WMNcPaint(var Msg: TMessage);
begin
inherited;

SendMessage(Self.Handle, WM_NCACTIVATE, WPARAM(GetForegroundWindow = Self.Handle), 0);
end;

WMNcPaint手続きの中でWMNcActivate手続きを呼ぶためにWM_NCACTIVATEメッセージを自身に投げています。
これをしないとクラシックスタイルでフォームが非アクティブでUnicodeな文字があるときに以前のCaptionが消えずに残ったままで文字が重なって表示されてしまうことがあります。

以下のコードでは上記の条件がそろった場合にタイトルバーの文字が重なってしまうのでNGとなります。

procedure TForm1.WMNcPaint(var Msg: TMessage);
begin
inherited;

//条件によって文字が重なってしまうためNG。
PaintCaption(F_sCaption, Self, (Msg.WParam <> 0));
end;

タイトルバーの文字列を変更するには以下のようなルーチンを作成しておくと便利かと思います。

procedure TForm1.F_SetCaption(sCaption: WideString);
begin
F_sCaption := sCaption;
SendMessage(Handle, WM_NCPAINT, 0, 0);
end;

問題点

対策

ちらつきに関しては表示するタイトルバーの文字列にUnicodeな文字がある場合のみこの独自処理を行い、そうでない場合はOSのデフォルトの処理に任せてしまうという手があります。
Unicodeな文字がある場合は結局ちらついてしまいますが、Unicodeな文字がない場合はちらつきません。

private
{ Private 宣言 }
F_sCaption: WideString; //タイトルバーに表示する文字列。
F_bUnicodeCaption: Boolean; //タイトルバーにUnicodeな文字があるか。

...

const
WC_NO_BEST_FIT_CHARS = $00000400;

function gfnbIsUnicode(sSrc: WideString): Boolean;
//sSrcにウムラウトのようなUnicode文字があればTrueを返す。
var
lb_Bool: LongBool;
begin
WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, PWideChar(sSrc), -1, nil, 0, nil, @lb_Bool);
Result := lb_Bool;
end;

procedure TForm1.F_SetCaption(sCaption: WideString);
begin
F_sCaption := sCaption;
F_bUnicodeCaption := gfnbIsUnicode(F_sCaption);
if (F_bUnicodeCaption) then begin
Caption := '';
SendMessage(Handle, WM_NCPAINT, 0, 0);
end else begin
Caption := F_sCaption;
end;
end;

procedure TForm1.WMNcActivate(var Msg: TMessage);
begin
inherited;

if (F_bUnicodeCaption) then begin
PaintCaption(F_sCaption, Self, (Msg.WParam <> 0));
end;
end;

この対策を行った場合GetTextWindow APIなどでこのフォームのウィンドウテキストを取得する場合Unicodeな文字がない場合はきちんと取得できるけれども、Unicodeな文字がある場合は空文字しか取得できないというちょっとややこしい現象になります。

ついでなのでフォームのCaptionプロパティを上書きしてみます。
こうすることでCaptionプロパティを操作することでUnicodeな文字をタイトルバーに設定したり取得したりできます。

private
{ Private 宣言 }
F_sCaption: WideString; //タイトルバーに表示する文字列。
F_bUnicodeCaption: Boolean; //タイトルバーにUnicodeな文字があるか。

published
property Caption: WideString read F_sCaption write F_SetCaption;

procedure TForm1.F_SetCaption(sCaption: WideString);
begin
F_sCaption := sCaption;
F_bUnicodeCaption := gfnbIsUnicode(F_sCaption);
if (F_bUnicodeCaption) then begin
inherited Caption := '';
SendMessage(Handle, WM_NCPAINT, 0, 0);
end else begin
inherited Caption := F_sCaption;
end;
end;

従来の(AnsiStringな)CaptionプロパティにアクセスするにはinheritedをCaptionの前につけます。

Windows 2000以前でIsThemeActive APIでエラーが出る場合はIsThemeActiveを静的リンクではなく動的リンクにすることで対処できます。