Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2021年12月02日] [更新 2021年12月24日]　Delphi 一般・その他
   
バルーンヒントウィンドウ
動作確認等 Windows 10 ビルド 19042 + Delphi XE5(UP2) Pro VCL-32
[整理番号 - 1110]






バルーンヒントウィンドウ


主に，Delphi 2009 で実装されたバルーンヒントの使用に関する記事とサンプルです．


[備考]
記事中の Application.OnShowHint イベント，Application.OnHint イベントをアプリケーションレベルで利用するには，フォームに TApplicationEvents コンポーネントを配置してイベントを実装すると便利です．




01_Hint プロパティによるヒント表示 ( ツールチップ表示 )


設計時の IDE で，フォームに配置したコントロールや IDE のオブジェクト上にマウスカーソルが移動，つまり，マウスオーパの状態になると，ポップアップウィンドウが短い時間表示さます．そこには，そのオブジェクトについての簡単なヒントが書かれてします．これをヒント，ヒントウィンドウ，あるいはツールチップと呼んでいます．


図1
ヒントウィンドウ
  • 設計時の TButton のヒントウィンドウ
図2
ヒントウィンドウ
  • コンポーネントパレット

Delphi では，コンポーネントの Hint プロパティに表示するテキストを設定して，ShowHint プロパティを True にしておくと，この機能を実装できます．下図はその例です．
ヒントが表示されるまでの時間とヒントが閉じるでの時間も Application 変数で設定できます．Delphi XE5 では複数行のテキストも設定可能になっています．

この方法によるヒントウィンドウの表示では，Application.OnShowHint, Application.OnHint 両方のイベントが発生します．


図3
ヒントを表示

リスト1
ヒントウィンドウを表示		 
//=============================================================================
//  フォーム生成時の処理
//  バルーンヒントではない通常のヒントウィンドウ (ツールチップ)
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  // 表示するまでの時間と表示してから閉じるまでの時間を設定
  // 単位はミリ秒
  Application.HintPause     := 300;
  Application.HintHidePause := 10000;

  Button1.Hint     := 'ヒント' + sLineBreak + '複数行の表示が可能';
  Button1.ShowHint := True;
end;


Screen 変数を使用すると，説明のテキストのフォントのサイズや色が変更できます．その例です．


図4
フォントサイズと色を変更

リスト2
ヒントウィンドウを表示．テキストのフォントサイズと色を変更		 
//=============================================================================
//  フォーム生成時の処理
//  バルーンヒントではない通常のヒントウィンドウ (ツールチップ)
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  // フォントを設定
  Screen.HintFont.Size  := 20;
  Screen.HintFont.Style := [fsBold];
  Screen.HintFont.Color := clBlue;

  // 表示するまでの時間と表示してから閉じるまでの時間を設定
  // 単位はミリ秒
  Application.HintPause     := 300;
  Application.HintHidePause := 10000;

  Button1.Hint     := 'ヒント' + sLineBreak + '複数行の表示が可能 ';
  Button1.ShowHint := True;
end;


ヒントウィンドウのカスタマイズ例です．このヒントウィンドウのクラス名は THintWindow です．このクラスの継承クラスを作成して Paint メソッド内で自前で描画します．HintWindowClass にこのクラスを指定しておきます．
Canvas に対する処理ですから，画像も描画可能です．



図5
カスタマイズの例

リスト3
ヒントウィンドウのカスタマイズ例．背景色とフォントサイズを変更		 
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls;

type
  TMyHint = class(THintWindow)
  protected
    procedure Paint; override;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
  private
    { Private 宣言 }
    FHint : TMyHint;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  Vcl.Themes;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//  バルーンヒントではない通常のヒントウィンドウ (ツールチップ)
//  THintWindow の継承クラスを作成して使用
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  // ヒントの表示に使用するクラスを指定
  // 指定可能なのは THintWindow の継承クラスのみ
  HintWindowClass := TMyHint;

  FHint := TMyHint.Create(Self);


  // フォントを設定
  Screen.HintFont.Size  := 20;
  Screen.HintFont.Style := [fsBold];

  // 表示するまでの時間と表示してから閉じるまでの時間を設定
  // 単位はミリ秒
  Application.HintPause     := 300;
  Application.HintHidePause := 10000;

  Button1.Hint     := 'ヒント' + sLineBreak + '複数行の表示が可能 ';
  Button1.ShowHint := True;
end;

{ TMyHint }

//=============================================================================
//  THintWindow の継承クラスの Paint メソッド
//=============================================================================
procedure TMyHint.Paint;
var
  LRect : TRect;
  LText : string;
begin
  inherited;

  LRect := Canvas.ClipRect;
  LText := Caption;

  if SameText(StyleServices.Name, 'Windows') then begin
    Canvas.Brush.Color := clWebWheat;
    Canvas.FillRect(LRect);
    Canvas.TextRect (LRect, LText, [tfLeft, tfWordBreak]);
   end;
end;

end.


ヒントウィンドウの表示は Application.OnShowHint で検知できます．
下図は，フォームに TApplicationEvents コンポーネントを配置して，その OnShowHint イベントでヒントウィンドウに表示するテキストを変更する例です．ヒントを表示したコントロールの名前と，そのコントロール内のマウスカーソル位置を追加表示します．


図6
OnShowHint イベントでヒントのテキストを変更

リスト4
OnShowHint イベントでヒントのテキストを変更． TApplicationEvents コンポーネントを使用		 
//=============================================================================
//  ApplicationEvents1 の OnShowHint イベント
//  ヒントウィンドウに表示するテキストを変更
//=============================================================================
procedure TForm1.ApplicationEvents1ShowHint(var HintStr: string;
  var CanShow: Boolean; var HintInfo: THintInfo);
var
  LText : string;
begin
  LText := HintInfo.HintControl.Name + sLineBreak
         + 'X : ' + IntToStr(HintInfo.CursorPos.X) + '  : '
         + 'Y : ' + IntToStr(HintInfo.CursorPos.Y);
  HintStr := HintStr + sLineBreak + LText;

  // 以下を実行するとヒントを表示しなくなる
  //  CanShow := False;
end;


下図はテーマを変更した結果です．


図7
テーマを変更
  • Amakrits
図8
テーマを変更
  • Metropolis UI Green




02_TBalloonHint を使用したバルーンヒントウィンドウ


TBalloonHint コンポーネントを使用すると，ヒントウィンドウのスタイルをバルーンにできます．バルーンウィンドウは，一般的には三角形の矢印付きのヒントウィンドウを意味します．BalloonHint コンポーネントをフォームにに配置します．ヒントを表示するコントロールの CustomHint プロパティに，配置した TBalloonHint コンポーネントを指定します．上のサンプルと同じく Hint プロパティに説明のテキストを設定して ShowHint プロパティを True にします．

TBalloonHint を使用してバルーンヒントを表示する場合，ヒントが表示されるまでの時間とヒントが閉じるでの時間は，TBalloonHint コンポーネントのプロパティで設定します．Screen 変数を使用してもフォントのサイズや色の変更はできません．

この方法によるバーンヒント表示では，Application.OnShowHint イベントは発生しませんが, Application.OnHint イベントは発生します．


図9
バルーンヒントを表示
  • フォームに TBalloonHint コンポーネントを配置

リスト5
TBalloonHint コンポーネントを使用してバルーンヒントを表示		 
//=============================================================================
//  フォーム生成時の処理
//  TBalloonHint コンポーネントを使用するが，通常のヒントウィンドウを表示する例
//
//  Application.HintPause, Application.HintHidePause の設定は無効
//  代わりに以下を使用する
//  TBalloonHint.Delay
//  TBalloonHint.HideAfter
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Button1.CustomHint := BalloonHint1;
  Button1.ShowHint := True;

  Button1.Hint := 'TBalloonHint を使用' + slineBreak
                + '普通のヒントウィンドウと同じ' + sLineBreak
                + '複数行の表示も可能';
end;



03_TBalloonHint を使用した画像付きバルーンヒントウィンドウ


TBalloonHint コンポーネントを使用すると，画像付きのバルーンヒントを表示することができます．下図のようにコンポーネントをフォームに配置します．TImageList には画像を追加しておきます．今回は，32 x 32 のアルファーチャンネル付きの 32 ビットの PNG 画像でテストしています．

TBalloonHint.Title プロパティでヒントウィンドウのタイトルを設定します．TBalloonHint.Description プロパティに説明用のテキストを指定します．ヒントウィンドウは ShowHint メソッドで表示します．つまり，この方式は，コントロールへのマウスカーバでヒントを表示するのではなく，通知用のメッセージ表示として利用することになります．
このサンプルでは，Button1 がクリックされたら，メッセージとしてのバルーンヒントを Button1 に表示します．

TBalloonHint を使用してバルーンヒントを表示する場合，ヒントが表示されるまでの時間とヒントが閉じるでの時間は，TBalloonHint コンポーネントのプロパティで設定します．Screen 変数を使用してもフォントのサイズや色の変更はできません．

この方法によるバルーンヒントの表示では，Application.OnShowHint イベントも Application.OnHint イベントも発生しません．


図10
設計時の画面
  • TBalloonHint と TImageList を配置
図11
オブジェクト・インスペクタの設定
  • TBalloonHint.Images プロパティに TImageList を指定する

図12
画像付きのバルーンヒント
  • Button1 がクリックされたら，メッセージとしてのバルーンヒントを表示
図13
タイトルがない場合
  • TBalloonHint.Title プロパティの値が空文字の場合

リスト6
TBalloonHint コンポーネントを使用して画像付きのバルーンヒントを表示		 
//=============================================================================
//  Button1 の OnClick イベント
//
//  TBalloonHint コンポーネントを使用して，ShowHint メソッドで表示する例
//  TBalloonHint.ShowHint メソッドで表示
//  閉じるのは TBalloonHint.HideHint メソッド
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LMousePos : TPoint;
begin
  BalloonHint1.HideAfter  := 10000;
  BalloonHint1.ImageIndex := 0;

  BalloonHint1.Title        := 'バルーンヒント';
  BalloonHint1.Description := '通知用メッセージとして使用可能　' + sLineBreak
                            + '複数行の表示可能' + sLineBreak;

  GetCursorPos(LMousePos);
  BalloonHint1.ShowHint(LMousePos);

  // 以下にすると規定の位置での表示となる
  // BalloonHint1.ShowHint(Button1);
end;


テキストのフォントサイズは，あらかじめ設定することはできませんが，テキスト描画後に上書き描画すれば可能です．そのためには TBalloonHint の継承クラスを作成して PaintHint メソッドで処理します．以下はその例です．

TCanvas のフォントを設定した後，描画する文字列からウィンドウの幅と高さを計算して，ヒントウィンドウの幅と高さを変更します．次に描画領域を算出してテキストを描画します．テーマを変更している場合は，そのテーマで描画するので描画コードを実行する必要はありません．最後にウィンドウの横方向の表示位置を調整しています．
このサンプルは，画像を表示しない時とタイトルを表示しない場合を考慮していません．また，画像のサイズも考慮していません．それらを考慮する場合は調整用の数値を変更する必要があります．

フォームに TBalloonHint コンポーネントを配置していますが使用していません．TBalloonHint は実行時に生成して使用しています．


図14
フォントサイズを変更

リスト7
フォントサイズを変更するための処理例		 
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls,
  Vcl.ImgList;

type
  TMyBalloonHint = class(TBalloonHint)
  public
    procedure PaintHint(HintWindow: TCustomHintWindow); override;
  end;

  TForm1 = class(TForm)
    Button1: TButton;
    BalloonHint1: TBalloonHint;
    ImageList1: TImageList;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
    FBalloonHint1 : TMyBalloonHint;
  end;

var
  Form1: TForm1;

implementation

uses
  Vcl.Themes;

{$R *.dfm}

//=============================================================================
//  フォーム生成時の処理
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  FBalloonHint1 := TMyBalloonHint.Create(Self);
  FBalloonHint1.Style := bhsBalloon;

  FBalloonHint1.Images := ImageList1;
end;

//=============================================================================
//  TBalloonHint コンポーネントを使用して，ShowHint メソッドで表示する例
//  フォントサイズ変更の TBalloonHint の継承クラスを生成して使用
//
//  TBalloonHint.ShowHint メソッドで表示
//  閉じるのは TBalloonHint.HideHint メソッド
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LMousePos : TPoint;
begin
  FBalloonHint1.HideAfter  := 10000;
  FBalloonHint1.ImageIndex := 0;

  FBalloonHint1.Title        := 'バルーンヒント';
  FBalloonHint1.Description := '通知用メッセージとして使用可能　' + sLineBreak
                             + '複数行の表示可能' + sLineBreak;

  GetCursorPos(LMousePos);
  FBalloonHint1.ShowHint(LMousePos);
end;


{ TMyBalloonHint }

type
  TMyHintWindow = class(TCustomHintWindow);

//-----------------------------------------------------------------------------
//  TBalloonHint の継承クラスの PaintHint メソッド
//-----------------------------------------------------------------------------
procedure TMyBalloonHint.PaintHint(HintWindow: TCustomHintWindow);
var
  LWidth  : Integer;
  LCanvas : TCanvas;
  LRect   : TRect;
  LText   : string;
  LList   : TStringList;
  LLen    : integer;
  LLenMax : Integer;
  LHeight : Integer;
  LIndex  : Integer;
begin
  inherited;

  LCanvas := TMyHintWindow(HintWindow).Canvas;

  LCanvas.Font.Size := 15;
  LCanvas.Font.Style := [fsBold];

  LWidth := HintWindow.Width;
  LRect  := HintWindow.ClientRect;
  LText  := HintWindow.Description;

  LList := TStringList.Create;
  try
    LList.Text := LText;
    LLenMax := 0;
    for LIndex := 0 to LList.Count - 1 do begin
      LLen := LCanvas.TextWidth(LList[LIndex]);
      if LLen > LLenMax then begin
        LLenMax := LLen;
      end;
    end;
    HintWindow.Width  := LLenMax + 50;
    HintWindow.Height := LCanvas.TextHeight('hg') * LList.Count + 65;;

    SetRect(LRect, LRect.Left + 40, LRect.Top + 50, LRect.Right - 1, LRect.Bottom - 1);
    if SameText(StyleServices.Name, 'Windows') then begin
      LCanvas.FillRect(LRect);
      LHeight :=  LCanvas.TextHeight('hg') * LList.Count;
      LRect.Top := LRect.Top + (LRect.Height - LHeight) div 2;
      LCanvas.TextRect (LRect, LText, [tfLeft, tfWordBreak]);
    end;
  finally
    FreeAndNil(LList);
  end;

  HintWindow.Left := HintWindow.Left - (HintWindow.Width - LWidth) div 2;
end;

end.


コントロールの OnMouseEnter イベント内で TBalloonHint.ShowHint メソッドを実行すれば，マウスオーパで画像付きバルーンヒントウィンドウを表示できます．



リスト8
マウスカーソルがコントロール内に移動したら画像付きバルーンヒントを表示		 
//=============================================================================
//  フォーム生成時の処理
//  TBalloonHint コンポーネントの使用例
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Button1.CustomHint := nil;
  Button1.ShowHint   := False;

  // TBalloonHint.Style を bhsBalloon にすると矢印なしになる
  BalloonHint1.Style := bhsBalloon;
end;

//=============================================================================
//  Button1 の OnMouseEnter イベント
//
//  TBalloonHint.ShowHint メソッドで表示
//  閉じるのは TBalloonHint.HideHint メソッド
//=============================================================================
procedure TForm1.Button1MouseEnter(Sender: TObject);
var
  LMousePos : TPoint;
begin
  BalloonHint1.HideAfter  := 5000;
  BalloonHint1.ImageIndex := 0;

  BalloonHint1.Title     := 'TBalloonHint';
  BalloonHint1.Description := 'OnMouseEnter イベントで表示　' + sLineBreak
                            + '複数行の表示可能' + sLineBreak;

  GetCursorPos(LMousePos);
  BalloonHint1.ShowHint(LMousePos);

  // 以下にすると規定の位置での表示となる
  // BalloonHint1.ShowHint(Button1);
end;


下図はテーマを変更した結果です．


図15
テーマを変更
  • Amakrits
図16
テーマを変更
  • Metropolis UI Green




04_閉じるボタン付きのバルーンヒントウィンドウ


閉じるボタン付きのバルーンヒントウィンドウを表示するコードとその動作確認のサンプルです．
このサンプルでは，Button1 がクリックされたら，メッセージとしてのバルーンヒントを Button1 に表示します．この閉じるボタンのバルーンヒントには，ウィンドウが表示されるまでの時間と，ウィンドウが閉じるでの時間の設定機能はありません．

この方法によるバルーンヒントの表示では，Application.OnShowHint イベントも Application.OnHint イベントも発生しません．


図17
閉じるボタン付きのバルーンヒント
  • Button1 がクリックされたら，メッセージとしてのバルーンヒントを表示
図18
閉じるボタン付きのバルーンヒント
  • TToolInfo.uFlags に TTF_CENTERTIP がない場合

リスト9
閉じるボタン付きのルーンヒントウィンドウを表示		 
  procedure ShowBalloonTip(Ctrl: TWinControl; Icon: HICON; const Title, Text: string);

var
  Form1: TForm1;

implementation

uses
  Winapi.CommCtrl;

{$R *.dfm}

var
  FhWndTip : THandle;

//=============================================================================
//  閉じるボタン付きのバルーンヒントを表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LText  : string;
  LhIcon : HICON;
begin
  LhIcon := LoadIcon(0, IDI_QUESTION);
  try
    LText := '主に通知表示用            ' + sLineBreak
           + '閉じるボタンで閉じる';
    ShowBalloonTip(Button1, LhIcon, '自作バルーンヒント', LText);
  finally
    DestroyIcon(LhIcon);
  end;
end;

//-----------------------------------------------------------------------------
//  閉じるボタン付きバルーンヒントを表示する手続き
//
//  Text が複数行の場合，2 行目以降が長いと全てが表示されない場合がある
//  1 行目の文字列またはタイトルの文字列に全角の空白文字を追加すると回避できる
//-----------------------------------------------------------------------------
procedure ShowBalloonTip(Ctrl: TWinControl; Icon: HICON; const Title, Text: string);
var
  LWndFlag  : Cardinal;
  LToolInfo : TToolInfo;
begin
  if FhWndTip <> 0 then begin
    PostMessage(FhWndTip, WM_CLOSE, 0, 0);
    FhWndTip := 0;
  end;

  LWndFlag := WS_POPUP or TTS_CLOSE or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP;
  FhWndTip := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, LWndFlag,
                             0, 0, 0, 0, Ctrl.Handle, 0, HInstance, nil);
  if FhWndTip = 0 then Exit;

  LToolInfo.cbSize   := SizeOf(TToolInfo);
  LToolInfo.uFlags   := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS;
  LToolInfo.hWnd     := Ctrl.Handle;
  LToolInfo.hInst    := HInstance;
  LToolInfo.lpszText := PChar(Text);
  LToolInfo.Rect     := Ctrl.ClientRect;

  SendMessage(FhWndTip, TTM_ADDTOOL, 0, integer(@LToolInfo));
  SendMessage(FhWndTip, TTM_SETTITLE, WPARAM(Icon), LPARAM(PChar(Title)));
  SendMessage(FhWndTip, TTM_TRACKACTIVATE, 1, LPARAM(@LToolInfo));
end;


テキストのフォントサイズの設定例です．変更可能なのは説明用のテキストだけです．タイトルの文字のサイズは変更できません．色関係の設定はできません．


図19
フォントのサイズを変更

リスト10
閉じるボタン付きのルーンヒントウィンドウを表示．フォントサイズの変更例		 
  procedure ShowBalloonTip(Ctrl: TWinControl; Icon: HICON; const Title, Text: string);

var
  Form1: TForm1;

implementation

uses
  Winapi.CommCtrl;

{$R *.dfm}

var
  FhWndTip : THandle;

//=============================================================================
//  閉じるボタン付きのバルーンヒントを表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LText  : string;
  LhIcon : HICON;
begin
  LhIcon := LoadIcon(0, IDI_QUESTION);
  try
    LText := '主に通知表示用   　　         ' + sLineBreak
           + 'フォントサイズ変更サンプル';
    ShowBalloonTip(Button1, LhIcon, '自作バルーンヒント', LText);
  finally
    DestroyIcon(LhIcon);
  end;
end;

//-----------------------------------------------------------------------------
//  閉じるボタン付きバルーンヒントを表示する手続き
//  フォントサイズ変更
//  変更可能なのは説明用テキストのみ
//  色関係の設定は実行しても無効
//
//  Text が複数行の場合，2 行目以降が長いと全てが表示されない場合がある
//  1 行目の文字列またはタイトルの文字列に全角の空白文字を追加すると回避できる
//-----------------------------------------------------------------------------
procedure ShowBalloonTip(Ctrl: TWinControl; Icon: HICON; const Title, Text: string);
var
  LWndFlag  : Cardinal;
  LToolInfo : TToolInfo;
  LFont     : TFont;
begin
  if FhWndTip <> 0 then begin
    PostMessage(FhWndTip, WM_CLOSE, 0, 0);
    FhWndTip := 0;
  end;

  LWndFlag := WS_POPUP or TTS_CLOSE or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP;
  FhWndTip := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, LWndFlag,
                             0, 0, 0, 0, Ctrl.Handle, 0, HInstance, nil);
  if FhWndTip = 0 then Exit;

  LFont := TFont.Create;
  try
    // フォントサイズ変更
    LFont.Size  := 20;
    LFont.Style := [fsBold];
    SendMessage(FhWndTip, WM_SETFONT, LFont.Handle, 0);

    LToolInfo.cbSize   := SizeOf(TToolInfo);
    LToolInfo.uFlags   := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS;
    LToolInfo.hWnd     := Ctrl.Handle;
    LToolInfo.hInst    := HInstance;
    LToolInfo.lpszText := PChar(Text);
    LToolInfo.Rect     := Ctrl.ClientRect;

    SendMessage(FhWndTip, TTM_ADDTOOL, 0, integer(@LToolInfo));
    SendMessage(FhWndTip, TTM_SETTITLE, WPARAM(Icon), LPARAM(PChar(Title)));
    SendMessage(FhWndTip, TTM_TRACKACTIVATE, 1, LPARAM(@LToolInfo));
  finally
    FreeAndNil(LFont);
  end;
end;


上のサンプルでは，システムに用意されている画像を表示しいます．次のようにすれば，画像ファイルの画像を読み込んで表示できます．


図20
画像ファイルを読み込んで表示

リスト11
閉じるボタン付きのルーンヒントウィンドウを表示．画像を読み込んで表示する例		 
//=============================================================================
//  閉じるボタン付きのバルーンヒントを表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LText : string;
  LIcon : TIcon;
begin
  LIcon := TIcon.Create;
  try
    LIcon.LoadFromFile('ACCOUNT_FUNCTIONS.ico');
    LText := '主に通知表示用　　　　　　　　' + sLineBreak
           + 'アイコン画像を読み出して表示';
    ShowBalloonTip(Button1, LIcon.handle, '自作バルーンヒント', LText);
  finally
    FreeAndNil(LIcon);
  end;
end;


ウィンドウの表示位置をスクリーン座標で指定できます．TToolInfo.hwnd の値を 0 にして，TToolInfo.Rect の値でスクリーン座標を指定します．この場合，ShowBalloonTip 関数内の Ctrl.Handle の値は 0 にして構いません． 以下のサンプルでは，ShowBalloonTip 関数にスクリーン座標値用の引数を設定しています．
自アプリ以外の場所に表示したい場合は以下を参考にしてください．


図21
ウィンドウの表示位置をスクリーン座標で指定

次のコードにすれば，マウスクリックの位置からバルーンヒントウィンドウを表示します．

 

    GetCursorPos(LPos);
    ShowBalloonTip(LPos, LhIcon, '自作バルーンヒント', LText);


図22
マウスクリックの位置に表示

リスト12
バルーンヒントウィンドウのひ表示位置をスクリーン座標値で指定する		 
  procedure ShowBalloonTip(APos: TPoint; Icon: HICON; const Title, Text: string);

var
  Form1: TForm1;

implementation

uses
  Winapi.CommCtrl;

{$R *.dfm}

var
  FhWndTip : THandle;

//=============================================================================
//  閉じるボタン付きのバルーンヒントを表示
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LText  : string;
  LhIcon : HICON;
  LPos   : TPoint;
begin
  LhIcon := LoadIcon(0, IDI_QUESTION);
  try
    LText := '主に通知表示用            ' + sLineBreak
           + '閉じるボタンで閉じる';

    LPos.X := Form1.Left + Form1.Width;
    LPos.Y := Form1.Top;
    ShowBalloonTip(LPos, LhIcon, '自作バルーンヒント', LText);
  finally
    DestroyIcon(LhIcon);
  end;
end;

//-----------------------------------------------------------------------------
//  閉じるボタン付きバルーンヒントを表示する手続き
//  表示位置を引数で指定 (スクリーン座標)
//
//  Text が複数行の場合，2 行目以降が長いと全てが表示されない場合がある
//  1 行目の文字列またはタイトルの文字列に全角の空白文字を追加すると回避できる
//-----------------------------------------------------------------------------
procedure ShowBalloonTip(APos: TPoint; Icon: HICON; const Title, Text: string);
var
  LWndFlag  : Cardinal;
  LToolInfo : TToolInfo;
begin
  if FhWndTip <> 0 then begin
    PostMessage(FhWndTip, WM_CLOSE, 0, 0);
    FhWndTip := 0;
  end;

  LWndFlag := WS_POPUP or TTS_CLOSE or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP;
  FhWndTip := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, LWndFlag,
                             0, 0, 0, 0, 0, 0, HInstance, nil);
  if FhWndTip = 0 then Exit;

  LToolInfo.cbSize      := SizeOf(TToolInfo);
  LToolInfo.uFlags      := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS;
  LToolInfo.hWnd        := 0;// Ctrl.Handle;
  LToolInfo.hInst       := HInstance;
  LToolInfo.lpszText    := PChar(Text);
  LToolInfo.Rect.Left   := APos.X;
  LToolInfo.Rect.Right  := LToolInfo.Rect.Left;
  LToolInfo.Rect.Top    := APos.Y;
  LToolInfo.Rect.Bottom := LToolInfo.Rect.Top;

  SendMessage(FhWndTip, TTM_ADDTOOL, 0, integer(@LToolInfo));
  SendMessage(FhWndTip, TTM_SETTITLE, WPARAM(Icon), LPARAM(PChar(Title)));
  SendMessage(FhWndTip, TTM_TRACKACTIVATE, 1, LPARAM(@LToolInfo));
end;


この閉じるボタン付きバルーヒントは，アプリを終了するか，閉じるボタンで閉じない限りヒントウィンドウを表示します．次のように，TTimer コンポーネントを使用すれば，ウィンドウを表示してから閉じるまでの時間の設定が可能になります．
TBalloonHint コンポーネントも内部で TTimer を使用しています．


リスト13
TTimer コンポーネントを使用して，一定時間悔過したらバルーンヒントウィンドウを閉じる		 
  procedure ShowBalloonTip(APos: TPoint; Icon: HICON; const Title, Text: string);

var
  Form1: TForm1;

implementation

uses
  Winapi.CommCtrl;

{$R *.dfm}

var
  FhWndTip : THandle;

//=============================================================================
//  閉じるボタン付きのバルーンヒントを表示
//  タイマーを使用して一定時間経過したら閉じる
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LText  : string;
  LhIcon : HICON;
  LPos   : TPoint;
begin
  Timer1.Enabled := False;

  LhIcon := LoadIcon(0, IDI_QUESTION);
  try
    LText := '主に通知表示用　　　　　　　　　　　　' + sLineBreak
           + 'タイマーで，閉じるまでの時間を設定';
    GetCursorPos(LPos);
    ShowBalloonTip(LPos, LhIcon, '自作バルーンヒント', LText);
  finally
    DestroyIcon(LhIcon);
  end;

  Timer1.Interval := 5000;
  Timer1.Enabled  := True;
end;

//=============================================================================
//  一定時間経過したらバルーンヒントを閉じる
//=============================================================================
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  if FhWndTip <> 0 then begin
    PostMessage(FhWndTip, WM_CLOSE, 0, 0);
    FhWndTip := 0;
    Timer1.Enabled := False;
  end;
end;

//-----------------------------------------------------------------------------
//  閉じるボタン付きバルーンヒントを表示する手続き
//  表示位置を引数で指定 (スクリーン座標)
//
//  フォントサイズ変更
//  変更可能なのは説明用テキストのみ
//  色関係の設定は実行しても無効
//
//  Text が複数行の場合，2 行目以降が長いと全てが表示されない場合がある
//  1 行目の文字列またはタイトルの文字列に全角の空白文字を追加すると回避できる
//-----------------------------------------------------------------------------
procedure ShowBalloonTip(APos: TPoint; Icon: HICON; const Title, Text: string);
var
  LWndFlag  : Cardinal;
  LToolInfo : TToolInfo;
  LFont     : TFont;
begin
  if FhWndTip <> 0 then begin
    PostMessage(FhWndTip, WM_CLOSE, 0, 0);
    FhWndTip := 0;
  end;

  LWndFlag := WS_POPUP or TTS_CLOSE or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP;
  FhWndTip := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, LWndFlag,
                             0, 0, 0, 0, 0, 0, HInstance, nil);
  if FhWndTip = 0 then Exit;

  LFont := TFont.Create;
  try
    // フォントサイズ変更
    LFont.Size  := 11;
    LFont.Style := [fsBold];
    SendMessage(FhWndTip, WM_SETFONT, LFont.Handle, 0);

    LToolInfo.cbSize   := SizeOf(TToolInfo);
    LToolInfo.uFlags   := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS;
    LToolInfo.hWnd     := 0;
    LToolInfo.hInst    := HInstance;
    LToolInfo.lpszText := PChar(Text);
    LToolInfo.Rect.Left   := APos.X;
    LToolInfo.Rect.Right  := LToolInfo.Rect.Left;
    LToolInfo.Rect.Top    := APos.Y;
    LToolInfo.Rect.Bottom := LToolInfo.Rect.Top;

    SendMessage(FhWndTip, TTM_ADDTOOL, 0, integer(@LToolInfo));
    SendMessage(FhWndTip, TTM_SETTITLE, WPARAM(Icon), LPARAM(PChar(Title)));
    SendMessage(FhWndTip, TTM_TRACKACTIVATE, 1, LPARAM(@LToolInfo));
  finally
    FreeAndNil(LFont);
  end;
end;


下図はテーマを変更した結果です．
本サンプルで表示するバルーンヒントウィンドウは，Windows のコモンコントロールがすべての描画を行っています．したがって，Delphi 自身のテーマの影響は受けません．


図23
テーマを変更
  • Amakrits
図24
テーマを変更
  • Metropolis UI Green




05_TBalloonHint への閉じるボタン [X] 追加の可能性


TBalloonHint のバルーンヒントウィンドウに閉じるボタン付 [X] を追加したいという質問がネットにありました．これは，ウィンドウのスタイルを動的に変更したいということになります．

ウィンドウのスタイルは，ウィンドウを生成する時に設定します．Delphi の TWinControl では CreateParams というメソッドが実装されています．このメソッドをオーバライドして生成時のウィンドウのスタイルが変更できます．表示中のウィンドウは，Windows API の SetWindowLong 関数で変更できます．
このことを，前項の閉じるボタン付きのバルーンヒントウィンドウで確認してみます．閉じるボタンを表示する TTS_CLOSE というフラグを除外してウィンドウを生成してみます．下図のように「閉じボタン」がありません．

 

procedure ShowBalloonTip(APos: TPoint; Icon: HICON; const Title, Text: string);
var
  LWndFlag  : Cardinal;
  LToolInfo : TToolInfo;
begin
  // TTS_CLOSE なしでウィンドウを作成
  LWndFlag := WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP;
  FhWndTip := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, LWndFlag,
                             0, 0, 0, 0, 0, 0, HInstance, nil);


図25
閉じるボタン [X] なしでウィンドウを生成

SetWindowLong 関数を使用して，ウィンドウのスタイルに TTS_CLOSE を追加した結果です．閉じるボタンが追加されているのが確認できます．
この閉じるボタンは，フォーム (ウィンドウ) のキャプションバー (タイトルバー) の閉じるボタンではありません． フォームの閉じるボタンは，フォームのシステムメニューとしてのボタンです．TTS_CLOSE の TTS は Tool Tip Style の略と解釈できます．

 

procedure ShowBalloonTip(APos: TPoint; Icon: HICON; const Title, Text: string);
var
  LWndFlag  : Cardinal;
  LToolInfo : TToolInfo;
  LWndStyle : NativeInt;
begin
  // TTS_CLOSE なしでウィンドウを作成
  LWndFlag := WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP;
  FhWndTip := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil, LWndFlag,
                             0, 0, 0, 0, 0, 0, HInstance, nil);

  // SetWindowLong 関数を使用して TTS_CLOSE を追加
  // TTS_CLOSE はキャプションバー (タイトルバー) の閉じるボタンではない
  LWndStyle := GetWindowLong(FhWndTip, GWL_STYLE);
  SetWindowLong(FhWndTip, GWL_STYLE, LWndStyle or TTS_CLOSE);


図26
SetWindowLong 関数で TTS_CLOSE を追加

下図は TBalloonHint のバルーンヒントウィンドウのデフォルトの状態です．


図27
TBalloonHint のデフォルトのウィンドウスタイル

以下のコードを使用して，SetWindowLong 関数で TBalloonHint のウィンドウスタイルを変更するコードを実行してみます．
TBalloonHint は TWinControl ではありません．TComponent --> TCustomHint --> TBalloonHint と派生したコンポーネントです．TWinControl ではないので CreateParams メソッドはありません．TBalloonHint が表示するウィンドウは，クラス名が TCustomHintWindow の HintWindow という変数のウィンドウです．これは，ShowHint メソッドでウィンドウを表示する際に生成されます．つまり内部的な変数です．外部からは操作できません．

TBalloonHint の継承クラスを作成して，PaintHint メソッド，あるいは SetHintSize メソッドをオーバライドすれば，そのメソッド内で HintWindow を操作できます．
下図は，SetHintSize メソッド内で SetWindowLong 関数を使用して，ウィンドウのスタイルに TTS_CLOSE を追加した結果ですが，閉じるボタンはありません．

 

//-----------------------------------------------------------------------------
//  TBalloonHint コンポーネントの継承クラスの SetHintSize メソッド
//-----------------------------------------------------------------------------
procedure TMyBalloonHint.SetHintSize(HintWindow: TCustomHintWindow);
var
  LWndStyle : NativeInt;
begin
  // ウィンドウのスタイルに TTS_CLOSE を追加
  LWndStyle := GetWindowLong(HintWindow.Handle, GWL_STYLE);
  SetWindowLong(HintWindow.Handle, GWL_STYLE, LWndStyle or TTS_CLOSE);

  inherited;
end;


図28
SetWindowLong 関数で TTS_CLOSE を追加

今度は TTS_CLOSE ではなく，WS_CAPTION を追加してみます．結果は下図の通りです．

 

//-----------------------------------------------------------------------------
//  TBalloonHint コンポーネントの継承クラスの SetHintSize メソッド
//-----------------------------------------------------------------------------
procedure TMyBalloonHint.SetHintSize(HintWindow: TCustomHintWindow);
var
  LWndStyle : NativeInt;
begin
  // ウィンドウのスタイルに WS_CAPTION を追加
  LWndStyle := GetWindowLong(HintWindow.Handle, GWL_STYLE);
  SetWindowLong(HintWindow.Handle, GWL_STYLE, LWndStyle or WS_CAPTION);

  inherited;
end;


図29
SetWindowLong 関数で WS_CAPTION を追加

TBalloonHint は，ShowHint メソッドが実行されると，ウィンドウを生成してバルーンヒントウィンドウをカスタム描画しています．それが PaintHint メソッドです．そのウィンドに自前で閉じるボタンを描画することは可能ですが，ボタンクリックを検知するには，おそらくマウスフックが必要です．TBalloonHint のウインドウはカスタム描画のウィンドウなので，Windows のコモンコントロールが発行する WM_NOTIFY メッセージはありません．
現実問題として，閉じるボタンの必要性を検討する必要があるかも知れません．






06_バルーンヒントウィンドウを自作
plBalloonHint.zip　[5.0 MB]　2021年12月26日版(次項のサンプルも同梱．EXE 同梱)


Delphi の TBalloonHint コンポーネントに対しての要望があるようです．それらは，文字のサイズの変更，背景色，閉じるボタンの追加，常に下方向，あるいは上に表示したい等です．一部については前掲のサンプルでその方法を示しました．閉じるボタンの可能性についても前項で確認しました．
バルーンヒントウィンドウを自作すれば，解決できる問題もあります．そこで，自作する場合に参考となるサンプルをユニットとして 作成してみました．ユニット名は plBalloonHint です．このファイルをライブラリのパスが通ったフォルダ内において，uses 部に追加して使用します．

最後に plBalloonHint のソースコートを掲載していますが，外部から使用可能なのは BalloonHint 関数だけです．この関数を実行すると，TCustomForm を継承したフォームを生成し，バルーンヒントウィンドウの形のリージョンを作成します．そこに関数の引数に渡したテキストやアイコン画像を描画します．
下図は BalloonHint 関数の使用例です．


図30
plBalloonHint ユニロットの使用例
  • システムのアイコンを描画
図31
plBalloonHint ユニロットの使用例
  • アイコン画像を読み込んで描画

plBalloonHint ユニロットを使用したバルーンヒントウィンドウの表示例 
implementation

uses
  plBalloonHint;

{$R *.dfm}

//=============================================================================
//  バルーンヒントウィンドウを表示
//  添付の自作バルーンヒントウィンドウの使用例
//
//  システムのアイコンを使用する例
//  TIcon のオブジェクトを生成しなくてもよい
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LTitle : string;
  LText  : string;
  LhIcon : HICON;
  LPos   : TPoint;
  LArrow : TBalloonArrow;
begin
  LTitle := 'ヒント';
  LText  := 'バルーンヒント表示テスト' + sLineBreak + '複数行可能';
  LArrow := baBottomRight;

  GetCursorPos(LPos);

  LhIcon := LoadIcon(0, IDI_INFORMATION);
  try
    BalloonHint(LTitle, LText, LhIcon, LArrow, LPos, 12000);
  finally
    DestroyIcon(LhIcon);
  end;
end;

//=============================================================================
//  バルーンヒントウィンドウを表示
//  添付の自作バルーンヒントウィンドウの使用例
//
//  TIcon を使用する例
//  引数に TIcon.Handle を渡す場合は TIcon.ReleaseHandle の処理が必要
//
//  添付のアイコン画像は 32 bit (サイズは 32 x 32)
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  LTitle : string;
  LText  : string;
  LIcon  : TIcon;
  LPos   : TPoint;
  LArrow : TBalloonArrow;
begin
  LTitle := 'ヒント';
  LText  := 'バルーンヒント表示テスト' + sLineBreak + '複数行可能';
  LArrow := baBottomLeft;

  GetCursorPos(LPos);

  LIcon := TIcon.Create;
  try
    LIcon.LoadFromFile('ACCOUNT_FUNCTIONS.ico');
    BalloonHint(LTitle, LText, LIcon.Handle, LArrow, LPos, 12000);
  finally
    LIcon.ReleaseHandle;
    FreeAndNil(LIcon);
  end;
end;


BalloonHint 関数の第 4 引数 ArrowPos (TBalloonArrow 型の変数) は，矢印とテキスト描画領域の位置関係の指定用です．以下のいずれかの値を指定します．baTopxxx を指定すると，常に矢印の上側にテキストを描画します．baBottomxxx を指定すると，常に矢印の下側にテキストを描画します．Center, Left, Right は水平方向の位置の指定です．

 

  TBalloonArrow = (baTopCenter, baTopLeft, baTopRight,
                   baBottomCenter, baBottomLeft, baBottomRight);


図32
baBottomCenter の場合
図33
baTopCenter の場合

plBalloonHint の Paint メソッドではテーマのスタイルに従った描画を行っていません．下図のようにスタイルを変更しても描画の結果が変わることはありません．



図34
tカスタム描画なのでテーマのスタイルの影響を受けない

テーマのスタイルによる描画にするには uses に Themes を追加して，StyleServices の機能を使用します．コンパイル時に警告が現れますが ThemeServices も使用可能です．変更が必要なのは Paint メソッド内の描画コードです．添付のコンポーネントの Paint メソッドのコードを参考にしてください．
テーマのスタイルの設定に従った描画にしても，アイコンの描画位置，文字のサイズと描画位置等は自由に設定できます．

テーマのスタイルに対応するということは，本項の冒頭で述べた「背景色を変更したい」とは相反することになります．本来の意味でのカスタム描画ではありませんが，必要であれば検討してください．

 

  // バルーンヒントの LDetails (TThemedElementDetails 型の変数)を取得
  LDetails := StyleServices.GetElementDetails(thHintBalloon);

  // 例えばテキストの色は以下の引数の LColor (TColor 型の変数) で取得
  // この色でテキストを描画する
　StyleServices.GetElementColor(LDetails, ecTextColor, LColor);


図35
テーマのスタイルに対応した場合
  • スタイル名は Amakrits

今回作成した plBalloonHint のソースコードです．
外部から実行可能な関数は BalloonHint だけです．この関数でバルーンヒントウィンドウを表示します．この関数の戻り値はバルーンヒントウィンドウのハンドルです．

コンポーネント化する場合，そのコンポーネントは，BalloonHint 関数に渡す値を設定するためのプロパティを実装します．例えば TComponent の派生クラスとします．そして，例えば ShowBalloonHint という名前のメソッドを実装して，そのメソッド内で BalloonHint 関数と同じようなコードを実行します．
この方針で作成したコンポーネントを同梱しています．そのコンポーネントの使用例が次項のサンプルです．


リスト14
バルーンヒントウィンドウを自作する場合の参考サンプル		 
unit plBalloonHint;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs;

type
  TBalloonArrow = (baTopCenter, baTopLeft, baTopRight,
                   baBottomCenter, baBottomLeft, baBottomRight);

  function BalloonHint(const Title, Text: string; AIcon: HICON;
    ArrowPos: TBalloonArrow; APos: TPoint; Duration: Cardinal = 0): HWND;

implementation

uses
  Winapi.CommCtrl,
  System.Types;

type
  TBalloonForm = class(TCustomForm)
  private
    FDuration: Cardinal;
    FArrowPos: TBalloonArrow;
    FRgnRect: TRect;
    FRegion: HRGN;
    FText: string;
    FInBtnRect : Boolean;
    FhTimer: Cardinal;
    function CalcBallonRect: TRect;
    procedure WMTimer(var Message: TWMTimer); message WM_TIMER;
  protected
    procedure Paint; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure Click; override;
    procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Popup(X, Y: Integer);
    property ArrowPos: TBalloonArrow read FArrowPos write FArrowPos;
    property Text: string read FText write FText;
    property Duration: Cardinal read FDuration write FDuration;
  end;

var
  FBalloonForm : TBalloonForm;
  FBtnRect   : TRect;
  FIconWidth : Integer;
  FBtnWidth  : Integer;
  FIconLeft  : Integer;
  FTextLeft  : Integer;
  FTextTop   : Integer;

  //-------------------------------------------------
  //  矢印 (三角形) 等の設定値
  //  FRadSize   : 矩形の角の丸み
  //  FArrowLen  : 矢印の長さ
  //  FArrowX1   : 三角形の底辺の X 座標
  //  FArrowX2   : 三角形の底辺のもう 1 つの X 座標
  //-------------------------------------------------
  FRadSize   : Integer = 2;
  FArrowLen  : Integer = 20;
  FArrowX1   : Integer = 16;
  FArrowX2   : Integer = 36;


//-----------------------------------------------------------------------------
//  バルーン型の図形 (リージョン) の作成
//-----------------------------------------------------------------------------
function CreateBalloonRgn(const Rect: TRect; Placement: TBalloonArrow): HRGN;
var
  LPoints   : array[0..2] of TPoint;
  LResRgn   : HRGN;
  LRectRgn  : HRGN;
  LArrowRgn : HRGN;
  LXStart   : Integer;
  LXEnd     : Integer;
  LXDes     : Integer;
begin
  LResRgn := CreateRectRgn(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);

  case Placement of
    baTopCenter, baTopLeft, baTopRight:
      LRectRgn := CreateRoundRectRgn(Rect.Left, Rect.Top,
        Rect.Right, Rect.Bottom - FArrowLen, FRadSize, FRadSize);
    else
      LRectRgn := CreateRoundRectRgn(Rect.Left, Rect.Top + FArrowLen,
        Rect.Right, Rect.Bottom, FRadSize, FRadSize);
  end;

  LXDes   := (FArrowX2 - FArrowX1) div 2;
  LXStart := (Rect.Width div 2) - LXDes;
  LXEnd   := (Rect.Width div 2) + LXDes;

  case Placement of
    baTopCenter:
      begin
        LPoints[0] := Point(LXStart, Rect.Bottom - FArrowLen - 1);
        LPoints[1] := Point(LXStart + LXDes, Rect.Bottom);
        LPoints[2] := Point(LXEnd, Rect.Bottom - FArrowLen - 1);
      end;
    baBottomCenter:
      begin
        LPoints[0] := Point(LXStart, Rect.Top + FArrowLen);
        LPoints[1] := Point(LXStart + LXDes, Rect.Top);
        LPoints[2] := Point(LXEnd, Rect.Top + FArrowLen);
      end;
    baTopLeft:
      begin
        LPoints[0] := Point(Rect.Right - FArrowX1, Rect.Bottom - FArrowLen - 1);
        LPoints[1] := Point(Rect.Right - FArrowX1, Rect.Bottom);
        LPoints[2] := Point(Rect.Right - FArrowX2, Rect.Bottom - FArrowLen - 1);
      end;
    baTopRight:
      begin
        LPoints[0] := Point(Rect.Left + FArrowX1, Rect.Bottom - FArrowLen - 1);
        LPoints[1] := Point(Rect.Left + FArrowX1, Rect.Bottom);
        LPoints[2] := Point(Rect.Left + FArrowX2, Rect.Bottom - FArrowLen  - 1);
      end;
    baBottomLeft:
      begin
        LPoints[0] := Point(Rect.Right - FArrowX1, Rect.Top + FArrowLen);
        LPoints[1] := Point(Rect.Right - FArrowX1, Rect.Top);
        LPoints[2] := Point(Rect.Right - FArrowX2, Rect.Top + FArrowLen);
      end;
    baBottomRight:
      begin
        LPoints[0] := Point(Rect.Left + FArrowX1, Rect.Top + FArrowLen);
        LPoints[1] := Point(Rect.Left + FArrowX1, Rect.Top);
        LPoints[2] := Point(Rect.Left + FArrowX2, Rect.Top + FArrowLen);
      end;
  end;
  LArrowRgn := CreatePolygonRgn(LPoints, Length(LPoints), WINDING);


  CombineRgn(LResRgn, LRectRgn, LArrowRgn, RGN_OR);
  Result := LResRgn;
  DeleteObject(LRectRgn);
  DeleteObject(LArrowRgn);
end;

{ TBalloonForm }

//=============================================================================
//  バルーンヒント用のウィンドウ (このフォーム) 生成メソッド
//=============================================================================
constructor TBalloonForm.Create(AOwner: TComponent);
begin
  inherited CreateNew(AOwner);

  if FBalloonForm <> nil then FBalloonForm.Release;

  BorderStyle  := bsNone;
  FBalloonForm := Self;
  FInBtnRect   := False;
  FBtnWidth    := 16;

  Width  := 200;
  Height := 200;
end;

//=============================================================================
//  CreateParams メソッド
//=============================================================================
procedure TBalloonForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);

  Params.Style   := WS_POPUP;
  Params.ExStyle := WS_EX_TOPMOST or WS_EX_NOACTIVATE;
  Params.WindowClass.style := Params.WindowClass.Style or CS_DROPSHADOW;
end;

//=============================================================================
//  バルーンヒント用のウィンドウ (このフォーム) 破棄時のメソッド
//=============================================================================
destructor TBalloonForm.Destroy;
begin
  if FBalloonForm = Self then FBalloonForm := nil;
  if FRegion <> 0 then DeleteObject(FRegion);
  if FhTimer <> 0 then KillTimer(Handle, FhTimer);

  inherited Destroy;
end;

//=============================================================================
//  表示する文字列の長さと行数から文字列を描画する矩形領域のサイズを計算
//  矢印の描画部分を除いた矩形領域
//  アイコンの描画開始 X 座標，テキストの描画開始 x, Y 座標も設定
//
//  テキストの折り返し表示がある場合の処理はない
//=============================================================================
function TBalloonForm.CalcBallonRect: TRect;
var
  LSize    : TSize;
  LPosX    : Integer;
  LPosY    : Integer;
  LStrings : TStrings;
  LIndex   : Integer;
begin
  // アイコンとテキストの描画開始位置
  if Icon.Handle = 0 then begin
    FIconWidth := 0;
    FIconLeft  := 0;
    FTextLeft  := 12;
  end else begin
    FIconWidth := Icon.Width;
    FIconLeft  := 8;
    FTextLeft  := FIconLeft + FIconWidth + FIconLeft + 5;
  end;
  FTextTop := 8;

  if Caption = '' then begin
    LSize.Width  := 0;
    LSize.Height := 0;
  end else begin
    LSize :=  Canvas.TextExtent(Caption);
  end;
  LPosX := LSize.cx;
  LPosY := LSize.cy;

  if Text <> '' then begin
    LStrings := TStringList.Create;
    try
      LStrings.Text := Text;
      if LStrings.Count > 0 then LPosY := LPosY + 8;
      for LIndex := 0 to LStrings.Count - 1 do begin
        LSize :=  Canvas.TextExtent(LStrings[LIndex]);
        if LSize.cx > LPosX then LPosX := LSize.cx;
        LPosY := LPosY + LSize.cy;
      end;
    finally
      FreeAndNil(LStrings);
    end;
  end;
  LPosX := LPosx + FTextLeft + 22;
  if (Caption = '') then begin
    LPosX := LPosX + FBtnWidth + 7;
  end;

  SetRect(Result, 0, 0, LPosX, LPosY);
end;

//=============================================================================
//  Popup メソッド
//  このフォームはこのメソッドで表示する
//=============================================================================
procedure TBalloonForm.Popup(X, Y: Integer);

  //----------------------------
  //  フォームの表示位置を調整
  //----------------------------
  procedure CalcFormPos(var X, Y: Integer);
  begin
    case FArrowPos of
      baTopCenter, baTopLeft, baTopRight:
        begin
          Y := Y - Height;
          if FArrowPos = baTopCenter then begin
            X := X - Width div 2;
          end else
          if FArrowPos = baTopLeft then begin
            X := X - Width + FArrowX1;
          end else begin
            X := X - FArrowX1;
          end;
        end;
      else
      if FArrowPos = baBottomCenter then begin
        X := X - Width div 2 ;
      end else
      if FArrowPos = baBottomLeft then begin
        X := X - Width + FArrowX1;
      end else begin
        X := X - FArrowX1;
      end;
    end;
  end;

begin
  // アイコンとテキスト描画の矩形領域を計算
  FRgnRect := CalcBallonRect;

  FRgnRect.Bottom := FRgnRect.Bottom + FArrowLen + FTextTop * 2;

  // このフォームのサイズ
  Width  := FRgnRect.Width;
  Height := FRgnRect.Height;

  // 表示位置を調整 (x 座標)
  CalcFormPos(X, Y);
  if FRegion <> 0 then DeleteObject(FRegion);

  // リージョンの作成と Windows への登録
  FRegion := CreateBalloonRgn(FRgnRect, FArrowPos);
  SelectClipRgn(Canvas.Handle, FRegion);
  SetWindowRgn(Handle, CreateBalloonRgn(FRgnRect, FArrowPos), True);

  // 表示
  SetWindowPos(Handle, HWND_TOPMOST, X, Y, Width, Height,
               SWP_SHOWWINDOW or SWP_NOACTIVATE);

   // タイマーの開始 (表示時間の制御)
  if FDuration = 0 then FDuration := 10000;
  FhTimer := SetTimer(Handle, 1, FDuration, nil);
end;

//=============================================================================
//  Paint メソッド
//  描画が必要になると自動的に実行されるメソッド
//  アイコン，テキスト等をこのフォームの Canvas に描画
//=============================================================================
procedure TBalloonForm.Paint;

  //-------------------------
  //  閉じるボタンを描画
  //-------------------------
  procedure DrawCloseBtn(ARect: TRect; AColor: TColor; DrawFrame: Boolean = True);
  var
    LRect : TRect;
  begin
    Canvas.Brush.Style := bsClear;
    Canvas.Pen.Color := AColor;
    Canvas.Pen.Width := 1;

    LRect := ARect;
    if DrawFrame then begin
      Canvas.Rectangle(LRect);
    end;

    InflateRect(LRect, -4, -4);
    Canvas.MoveTo(LRect.Left, LRect.Top);
    Canvas.LineTo(LRect.Right, LRect.Bottom);
    Canvas.MoveTo(LRect.Right, LRect.Top);
    Canvas.LineTo(LRect.Left, LRect.Bottom);
  end;

var
  LBaseRect : TRect;
  LRect     : TRect;
  LBtnXPos  : Integer;
  LBtnYPos  : Integer;
begin
  case FArrowPos of
    baTopCenter, baTopLeft, baTopRight:
    begin
      SetRect(LBaseRect, FRgnRect.Left, FRgnRect.Top,
        FRgnRect.Left + Width, FRgnRect.Top + Height - FArrowLen);
    end;
  else
    begin
      SetRect(LBaseRect, FRgnRect.Left, FRgnRect.Top + FArrowLen,
        FRgnRect.Left + Width, FRgnRect.Top + Height);
    end;
  end;


  // バルーン型の図形 (リージョン) の塗り潰しと輪郭線の描画
  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := $00E1FFFF;
  FillRgn(Canvas.Handle, FRegion, Canvas.Brush.Handle);
  FrameRgn(Canvas.Handle, FRegion, GetStockObject(GRAY_BRUSH), 1, 1);

  LRect := LBaseRect;
  Canvas.Brush.Style := bsClear;

  // アイコンを描画
  if Icon.Handle <> 0 then begin
    Canvas.Draw(LRect.Left + FIconLeft, LRect.Top + FTextTop + 2, Icon);
  end;

  // タイトルを描画
  if Caption <> '' then begin
    Canvas.Font.Style := [fsBold];
    Canvas.Font.Color := clBlue;
    Canvas.TextOut(LRect.Left + FTextLeft, LRect.Top + FTextTop, Caption);
  end;

  Canvas.Font.Color := clBlack;
  // テキストを描画
  if FText <> '' then begin
    Canvas.Font.Style := [];
    if Caption <> '' then begin
      LRect.Top  := LRect.Top + Canvas.TextHeight(Caption) + FTextTop + 5;
    end else begin
      LRect.Top  := LRect.Top + FTextTop;
    end;
    LRect.Left := LRect.Left + FTextLeft;
    Canvas.TextRect(LRect, FText, []);
  end;

  // 閉じるボタンの描画位置
  LBtnXPos := LBaseRect.Right - FBtnWidth - 10;
  LBtnYPos := LBaseRect.Top + 6;
  SetRect(FBtnRect, LBtnXPos, LBtnYPos, LBtnXPos + FBtnWidth, LBtnYPos + FBtnWidth);

  // 閉じるボタンを描画
  DrawCloseBtn(FBtnRect, clGray, FInBtnRect);
end;

//=============================================================================
//  WM_TIMER メッセージ
//  WM_ACTIVATE メッセージ処理
//  このウィンドウはアクティブ化させない
//=============================================================================
procedure TBalloonForm.WMActivate(var Message: TWMActivate);
begin
  if Message.Active <> WA_INACTIVE then begin
    SetActiveWindow(Message.ActiveWindow);
  end;
end;

//=============================================================================
//  WM_TIMER メッセージ
//  指定時間を経過したらこのフォームを破棄
//=============================================================================
procedure TBalloonForm.WMTimer(var Message: TWMTimer);
begin
  KillTimer(Handle, FhTimer);
  FhTimer := 0;
  Release;
end;

//=============================================================================
//  このフォームの Click メソッド
//=============================================================================
procedure TBalloonForm.Click;
begin
  inherited;
//  例えは Release; (このフォームを閉じる) 等を実行
end;

//=============================================================================
//  このフォームの MouseUp メソッド
//  追加描画したボタンの上で Mouseup したらこのフォームを破棄 (つまり閉じる)
//=============================================================================
procedure TBalloonForm.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;

  if Button = mbLeft then begin
    if PtInRect(FBtnRect, Point(X, Y)) then begin
      Release;
    end;
  end;
end;

//=============================================================================
//  このフォームの MouseMove メソッド
//  閉じるボタンの描画を変更
//=============================================================================
procedure TBalloonForm.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;

  if PtInRect(FBtnRect, Point(X, Y)) and not FInBtnRect then begin
    FInBtnRect := True;
    Invalidate;
  end else
  if not PtInRect(FBtnRect, Point(X, Y)) and FInBtnRect then begin
    FInBtnRect := False;
    Invalidate;
  end;
end;

//-----------------------------------------------------------------------------
//  外部から使用する関数
//  バルーンヒントウィンドウを生成して表示
//
//  Title    : タイトルの文字列．1 行のみ
//  Text     : テキスト
//  Icon     : アイコンのハンドル．使用しない場合は 0 とする
//  ArrowPos : フォームの相対表示位置．TBalloonArrow 型の値
//  APos     : 表示位置をスクリーン座標で指定 (矢印の先端の座標)
//  Duration : 表示時間 (ミリ秒)．1 秒未満も可．0 の時はデフォルトの 10 秒
//             Cardinal(-1) にすれば事実上自動で閉じないのと同じ
//
//  [備考]
//  (1) ArrowPos が baTopxxx の時は APos.Y 座標から上に表示
//      ArrowPos が baBottomxxx の時は APos.Y 座標よりも下に表示
//  (2) 表示開始までの時間の設定はない
//-----------------------------------------------------------------------------
function BalloonHint(const Title, Text: string; AIcon: HICON;
  ArrowPos: TBalloonArrow; APos: TPoint; Duration: Cardinal = 0): HWND;
begin
  FBalloonForm := TBalloonForm.Create(Application);

  FBalloonForm.Font.Size := 13;

  FBalloonForm.Caption     := Title;
  FBalloonForm.Text        := Text;
  FBalloonForm.Icon.Handle := AIcon;
  FBalloonForm.ArrowPos    := ArrowPos;
  FBalloonForm.Duration    := Duration;

  FBalloonForm.Popup(APos.X, APos.Y);
  Result := FBalloonForm.Handle;
end;

end.


スクリーンの上端，下端，左端，右端のチェックをして表示位置を変更する場合は，PopUp メソッド内で処理します．例えば以下のようよします．

 

  // 表示位置を調整 (x 座標)
  CalcFormPos(X, Y);

  // 右端のチェックの場合
  if (X + Width) > Screen.Width then begin
    if FArrowPos = baTopRight    then FArrowPos := baTopLeft;
    if FArrowPos = baBottomRight then FArrowPos := baBottomLeft;
    // フォームの表示位置を再計算
    CalcFormPos(X, Y);
  end;
  if FRegion <> 0 then DeleteObject(FRegion);


[備考]
ポップアップメニュー等，親を持たないオーパラップなウィンドウにはコントロール類 (コンポーネント類) を配置することはできません．フォームだけは例外的にコントロール類を配置することができます．
ただし，本サンプルのバルーンヒントウィンドウのフォームにはコントロール類を配置することはできません．本サンプルのフォームは，CreateNew メソッドでフォームを生成しています．CreateNew メソッドで生成したフォームにはコントロール類を配置することができませんが，dfm ファイル，フォームのリソースファイルなしてフォームを生成することができます．




07_バルーンヒントウィンドウにボタン追加とカスタマイズ


今回作成したバルーンヒントウィンドウ表示用のコンポーネントを使用して，バルーンヒントウィンドウにボタン等を追加したり描画をカスタマイズする例です．実際には TButton 等は配置できません．画像として描画します．


図36
設計時の画面
  • 作成した TplBalloonHint コンポーネントを配置

オブジェクト・インスペクタでイベントを実装します．今回実行するのは下図のイベントです．


図37
イベントを実装
  • OnMouseDown イベント
    OnClick ではなく MouseDown にしてみた
  • OnPaint イベント
  • OnSize イベント

下図は科実行結果です．追加した [閉じる] ボタンの上でマウスの左ボタンを押すと，バルーンヒントウィンドウが閉じます．このサンプルでは，元の閉じるボタンは非表示にしています．
このバルーンヒントウィンドウは入力フォーカスを受け取る状態になることはありません．したがって，キー操作のイベントは受信できません．


図38
実行画面

リスト15
バルーンヒントウィンドウにボタンを追加する例		 
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls,
  plBalloonHintEx;

type
  TForm1 = class(TForm)
    Button1: TButton;
    plBalloonHint1: TplBalloonHint;
    procedure Button1Click(Sender: TObject);
    procedure plBalloonHint1Paint(Sender: TObject; ACanvas: TCanvas;
      ARect: TRect);
    procedure plBalloonHint1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure plBalloonHint1Size(Sender: TObject; var NewWidth,
      NewHeight: Integer);
  private
    { Private 宣言 }
    FAddBtn1Rect : TRect;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  Vcl.Themes,
  System.Types;

{$R *.dfm}

//=============================================================================
//  バルーンヒントウィンドウを表示
//  システムのアイコン画像を表示する例
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LPos  : TPoint;
begin
  plBalloonHint1.Title    := '情報';
  plBalloonHint1.Text     := 'バルーンヒント表示テスト' + sLineBreak + '複数行可能';
  plBalloonHint1.Duration     := Dword(-1);
  plBalloonHint1.BkgColor     := clWebKhaki;
  plBalloonHint1.ShowCloseBtn := False;

  plBalloonHint1.FontSize := 13;

  GetCursorPos(LPos);
  plBalloonHint1.Pos := LPos;

  plBalloonHint1.Icon.Handle := LoadIcon(0, IDI_INFORMATION);
  plBalloonHint1.ShowBalloonHint;
end;

//=============================================================================
//  TplBalloonHint の OnSize イベント
//  このイベントでバルーンヒントウィンドウのサイズ変更が可能
//  ボタンを追加するのその分ウィンドウの高さを増やす
//=============================================================================
procedure TForm1.plBalloonHint1Size(Sender: TObject; var NewWidth,
  NewHeight: Integer);
begin
  NewHeight := NewHeight + 30;
end;

//=============================================================================
//  TplBalloonHint の OnPain イベント
//  テーマのボタンを追加描画
//=============================================================================
procedure TForm1.plBalloonHint1Paint(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect);
var
  LDetails  : TThemedElementDetails;
  LText     : string;
  LColor    : TColor;
begin
  SetRect(FAddBtn1Rect, ARect.Left + 16, ARect.Bottom - 32,
    ARect.Left + 76, ARect.Bottom - 10);

  // テーマのボタンを描画
  LDetails := StyleServices.GetElementDetails(tbPushButtonDefaulted);
  StyleServices.DrawElement(ACanvas.Handle, LDetails, FAddBtn1Rect);

  // ボタンの Caption を描画
  StyleServices.GetElementColor(LDetails, ecTextColor, LColor);
  LText := '閉じる';
  ACanvas.Font.Size  := 9;
  ACanvas.Font.Color := LColor;
  ACanvas.Brush.Style := bsClear;
  ACanvas.TextRect(FAddBtn1Rect, LText, [ tfSingleLine, tfVerticalCenter, tfCenter]);
end;

//=============================================================================
//  TplBalloonHint の OnMouseDown イベント
//  追加したボタン上で MouseDown したらヒントウィンドウを閉じる
//  ボタンクリックと同じ動作を実現する
//
//  本来は OnClick の処理にすべきであるが OnMouseDown のテストとした
//=============================================================================
procedure TForm1.plBalloonHint1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then begin
    if PtInRect(FAddBtn1Rect, Point(X, Y)) then begin
      plBalloonHint1.CloseBalloonHint;
    end;
  end;
end;

end.


TplBalloonHint コンポーネントでテキスト等の描画をカスタマイズする際の参考コードです．このサンプルでは，描画内容に関するプロパティを設定しないでバルーンヒントウィンドウを表示します．そのままではウィンドウのサイズが小さすぎます．そこで，OnSize イベントでウィンドウのサイズを設定します．描画は OnPaint イベントで実行します．


図39
実行画面
  • OnPaint イベント内で描画する

リスト16
描画をカスタマイズする際の参考サンプル		 
//=============================================================================
//  バルーンヒントウィンドウを表示
//  描画内容を指定しない例
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LPos : TPoint;
begin
  GetCursorPos(LPos);
  plBalloonHint1.Pos := LPos;
  plBalloonHint1.ShowBalloonHint;
end;

//=============================================================================
//  TplBalloonHint の OnSize イベント
//  このイベントでバルーンヒントウィンドウのサイズ変更が可能
//=============================================================================
procedure TForm1.plBalloonHint1Size(Sender: TObject; var NewWidth,
  NewHeight: Integer);
begin
  NewWidth  := 250;
  NewHeight := 200;
end;

//=============================================================================
//  TplBalloonHint の OnPaint イベント
//  自由な描画が可能
//=============================================================================
procedure TForm1.plBalloonHint1Paint(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect);
begin
  ACanvas.Font.Size  := 25;
  ACanvas.TextOut(ARect.Left + 50, ARect.Top + 25, '情報');
end;


次も描画をカスタマイズする際の参考コードです．バルーンヒントウィンドウの背景を塗り潰します．これで自由に描画できます．
Title プロパティの値も Text プロパティの値も実行時に変更できますが，ウィンドウのサイズが変わることはありません．


図40
バルーンヒントウィンドウの背景を塗り潰した結果
  • 描画は OnPaint イベントで行うことになる

リスト17
バルーンヒントウィンドウの背景を塗り潰す		 
//=============================================================================
//  バルーンヒントウィンドウを表示
//  システムのアイコン画像を表示する例
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  LPos : TPoint;
begin
  plBalloonHint1.Title    := '情報';
  plBalloonHint1.Text     := 'バルーンヒント表示テスト' + sLineBreak + '複数行可能';

  GetCursorPos(LPos);
  plBalloonHint1.Pos := LPos;

  plBalloonHint1.Icon.Handle := LoadIcon(0, IDI_INFORMATION);
  plBalloonHint1.ShowBalloonHint;
end;

//=============================================================================
//  TplBalloonHint の OnSize イベント
//  このイベントでバルーンヒントウィンドウのサイズ変更が可能
//=============================================================================
procedure TForm1.plBalloonHint1Size(Sender: TObject; var NewWidth,
  NewHeight: Integer);
begin
  NewWidth  := 250;
  NewHeight := 200;
end;

//=============================================================================
//  TplBalloonHint の OnPain イベント
//  バルーンヒントウィンドウの背景を塗り潰す
//=============================================================================
procedure TForm1.plBalloonHint1Paint(Sender: TObject; ACanvas: TCanvas;
  ARect: TRect);
begin
  ACanvas.Brush.Color := clWebKhaki;
  ACanvas.FillRect(ACanvas.ClipRect);
end;