ポップアップメニュー(TPopupMenu) のメニュー項目を画像にするサンプルです．
メニューの項目のカスタマイズに応用できます．例えば，フォント変更等の用途にも応用できます．
以下の方針で作成しています．
- 最初の，先頭の項目に 4 つの画像を表示
- 各々の画像のクリックを別々に検出する(クリッカブルマップの様な機能)
- マウスカーソル位置の画像の背景色を変更する
下図は作成した EXE を実行した画像です．
テストなので，マウスカーソルの位置を表示するようにしています．
フォームに配置しているボタンは，操作とは無関係です．
TPopupMenu は，Windows API の TrackPopupMenu を実行しています．したがって，Delphi のコントロールのように，ボタン等は配置できません．OnAdvancedDrawItem イベントあるいは OnDrawItem イベントで描画することになります．
OnAdvancedDrawItem イベントには State 変数があり，Disable 等の画像を表示したりする時に便利です．
マウスカーソル位置の画像を知るためには，TPopupMenu ウィンドウ上のマウスカーソルの位置を知る必要があります．このために，マウスのローカルフックを使用しています．
TPopupMenu ウィンドウ上のマウスカーソル位置は，TApplication の OnMessage イベントでは捕捉できません．詳しくは以下を参考にしてください．
[第７章 メッセージを捕まえる : ローカルフック - Halbow]
http://mrxray.on.coocan.jp/Halbow/VCL07.html
[フック関数のインスタンス化 - Halbow]
http://mrxray.on.coocan.jp/Halbow/Notes/N006.html
マウスフックは，プログラム開始と同時に開始し，終了時に終了してもいいのですが，本サンプルでは，PopupMenu の表示開始と同時にフックを開始し，PopupMenu が閉じたらフックを終了しています．
そのために，TPopupMenu を表示開始した時と，閉じた時のメッセージを受信するようにしています．
マウスカーソルがある画像の背景色を変更するには，マウスカーソルが，対象の画像内に入った時に TPopupMenu を再描画することになります．
マウスカーソルが移動する度に再描画してしまうと，再描画によるチラつきが発生します．そこで，マウスカーソルがある画像の番号をグローバル変数に取得しておき，マウスカーソルが別の画像位置に入ったら再描画するようにしています．
以下は，設計時の画面と実際にテストに使用したコードです．
設計時に TImageList に描画する画像を格納しておき，実行時に描画用のイベント内でその画像を描画します．
TPopupMenu には，適当にメニュー項目を作成しておきます．
また，TPopupMenu の OwnerDrawプロパティをTrueにしておきます．
サンプルでは，Form1 の PopupMenu プロパティを PopupMenu1 にしています．
以下も参考にしてください．
http://mrxray.on.coocan.jp/bbs/DelphiBBS/mrxray_delphifan_coffe.cgi?tree=s8044#8044
サンプルのプロジェクトのダウンロード(EXE 同梱 : 1.122 KB 2014年10月08日版
http://mrxray.on.coocan.jp/Delphi/zip/PopupMenu_ImageItem.zip
動作確認は Wondos 7 U64(SP1) + Delphi XE(UP1) Pro ですが，おそらく Delphi 6 以降で使用可能と思われます．
[別バージョンで作成されたプロジェクトの利用]
http://mrxray.on.coocan.jp/Delphi/Others/Delphi_Versionl.htm
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Menus, ImgList;
type
TPopupListEx = class(TPopupList)
protected
procedure WndProc(var Message: TMessage) ; override;
end;
TForm1 = class(TForm)
Button1: TButton;
PopupMenu1: TPopupMenu;
Item_0: TMenuItem;
Item_1: TMenuItem;
Item_2: TMenuItem;
Item_3: TMenuItem;
N1: TMenuItem;
ImageList1: TImageList;
Panel1: TPanel;
procedure Item_0AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas;
ARect: TRect; State: TOwnerDrawState);
procedure Item_0MeasureItem(Sender: TObject; ACanvas: TCanvas; var Width,
Height: Integer);
procedure FormCreate(Sender: TObject);
procedure Item_0Click(Sender: TObject);
private
{ Private 宣言 }
RectImage : array [0..3] of TRect;
hPopupWnd : HWND;
CurrentImgIndex : Integer;
protected
procedure WMExitMenuLoop(var Message: TWMExitMenuLoop);
message WM_EXITMENULOOP;
procedure WMEnterMenuLoop(var Message: TWMEnterMenuLoop);
message WM_ENTERMENULOOP;
public
{ Public 宣言 }
procedure WMApp100(var Message: TMessage); message WM_APP+100;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
var
hMouseHook : HHOOK;
//-----------------------------------------------------------------------------
// マウスフックのコールバック関数
// Form1にメッセージを送る
//-----------------------------------------------------------------------------
function MouseHookProc(nCode: Integer; wPar: WPARAM; lPar: LPARAM):
Integer; stdcall;
var
MousePos : TPoint;
begin
if nCode < 0 then begin
Result := CallNextHookEx(hMouseHook, nCode, wPar, lPar);
end else begin
if nCode = HC_ACTION then begin
MousePos := PMouseHookStruct(lPar)^.pt;
PostMessage(Form1.Handle, WM_APP+100, wPar, MakeLParam(MousePos.X, MousePos.Y));
end;
Result := CallNextHookEx(hMouseHook, nCode, wPar, lPar);
end;
end;
//-----------------------------------------------------------------------------
// フォーム生成時の処理
//-----------------------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
begin
//予め設定しておかないと，一番最初のビットマップが透過状態にならなかったので
ImageList1.BkColor := clFuchsia;
end;
//-----------------------------------------------------------------------------
// PopupMenuが表示された時のメッセージ処理
// マウスフックを開始する
//-----------------------------------------------------------------------------
procedure TForm1.WMEnterMenuLoop(var Message: TWMEnterMenuLoop);
begin
if hMouseHook = 0 then begin
hMouseHook := SetWindowsHookEx(WH_MOUSE, @MouseHookProc, 0, GetCurrentThreadID);
end;
//PopupMenu1のウィンドウハンドルを取得
//Windwosのポップアップメニューのクラス名は#32768
//32768は16進数に変換すると$8000
hPopupWnd := FindWindow('#32768', nil);
CurrentImgIndex := -1;
end;
//-----------------------------------------------------------------------------
// PopupMenuが閉じた時のメッセージ処理
// マウスフックを終了する
//-----------------------------------------------------------------------------
procedure TForm1.WMExitMenuLoop(var Message: TWMExitMenuLoop);
begin
if hMouseHook <> 0 then begin
UnhookWindowsHookEx(hMouseHook);
hMouseHook := 0;
end;
hPopupWnd := 0;
Panel1.Caption := '閉じた';
end;
//-----------------------------------------------------------------------------
// PopupMenu1のItem_0項目のOnAdvancedDrawItemイベント処理
// ImageListに格納してあるビットマップ画像を表示
// 本サンプルでは，Item_0(TMenuItem)が画像を表示するメニュー項目
//
// PopupMenu1のOwnerDrawプロパティをTrueにしておく
// ImageList1にビットマップ画像を4つ格納しておく
//-----------------------------------------------------------------------------
procedure TForm1.Item_0AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas;
ARect: TRect; State: TOwnerDrawState);
var
aBitmap : TBitmap;
ItemWidth : Integer;
ItemHeigh : Integer;
DrawPos : TPoint;
RectImgPos : TPoint;
infMarginX : Integer;
infMarginY : Integer;
i : Integer;
RectDraw : TRect;
begin
if TMenuItem(Sender) = Item_0 then begin
ItemWidth := ImageList1.Width + 6;
ItemHeigh := ImageList1.Height + 6;
RectImgPos := PopupMenu1.PopupPoint;
Windows.ScreenToClient(hPopupWnd, RectImgPos);
aBitmap := TBitmap.Create;
try
infMarginX := 10;
infMarginY := 5;
InflateRect(ARect, -infMarginX, -infMarginY);
RectImgPos.X := PopupMenu1.PopupPoint.X + (ARect.Left - RectImgPos.X);
RectImgPos.Y := PopupMenu1.PopupPoint.Y + (ARect.Top - RectImgPos.Y);
DrawPos.X := ARect.Left;
DrawPos.Y := ARect.Top;
for i := 0 to Length(RectImage) - 1 do begin
//スクリーン座標値での描画領域
RectImage[i] := Rect(RectImgPos.X, RectImgPos.Y,
RectImgPos.X + ItemWidth,
RectImgPos.Y + ItemHeigh);
aBitmap.Assign(nil);
ImageList1.GetBitmap(i, aBitmap);
aBitmap.Transparent := True;
//クライアント座標値での描画領域
RectDraw := Rect(DrawPos.X, DrawPos.Y,
DrawPos.X + ItemWidth,
DrawPos.Y + ItemHeigh);
if i = CurrentImgIndex then begin
ACanvas.Brush.Style := bsSolid;
ACanvas.Brush.Color := clMenuHighlight;
ACanvas.FillRect(RectDraw);
end else begin
ACanvas.Brush.Style := bsClear;
ACanvas.Brush.Color := clMenu;
ACanvas.FillRect(RectDraw);
end;
ACanvas.Draw(DrawPos.X + 3, DrawPos.Y + 3, aBitmap);
DrawPos.X := DrawPos.X + ItemWidth;
RectImgPos.X := RectImgPos.X + ItemWidth;
end;
finally
aBitmap.Free;
end;
end;
end;
//-----------------------------------------------------------------------------
// PopupMenu1のItem_0項目のOnMeasureItemイベント処理
// 項目の幅と高さを設定
//-----------------------------------------------------------------------------
procedure TForm1.Item_0MeasureItem(Sender: TObject; ACanvas: TCanvas; var Width,
Height: Integer);
var
infMarginX : Integer;
infMarginY : Integer;
begin
//上のイベント内の定義と同じ値にする
infMarginX := 10;
infMarginY := 5;
//+5の値は上のイベントの設定したImageList1.Width + 5等と同じにする
Width := (ImageList1.Width + 5) * Length(RectImage) + infMarginX;
Height := ImageList1.Height + 5 + infMarginY * 2;
end;
//-----------------------------------------------------------------------------
// TMenuItemのItemのOnClickイベント処理
// 全てのItemの共有イベント
// 本サンプルでは，Item_0(TMenuItem)が画像を表示するメニュー項目
//-----------------------------------------------------------------------------
procedure TForm1.Item_0Click(Sender: TObject);
begin
if TMenuItem(Sender) = Item_0 then begin
//メニューをクリックした時は，画像のインデックスを表示
//実際には，取得した番号によって処理を分岐することになる
if CurrentImgIndex >= 0 then begin
ShowMessage(IntToStr(CurrentImgIndex + 1) + ' 番目の画像クリック');
end;
end;
end;
//-----------------------------------------------------------------------------
// ローカルマウスフックのメッセージを受信
// マウスカーソルの座標値を取得して表示
//-----------------------------------------------------------------------------
procedure TForm1.WMApp100(var Message: TMessage);
var
X : Integer;
Y : Integer;
aRect : TRect;
i : Integer;
Flags : Cardinal;
NewImgIndex : Integer;
begin
if hPopupWnd = 0 then exit;
X := LOWORD(Message.LParam);
Y := HIWORD(Message.LParam);
//PopupMen1のウィンドウの領域内の時だけ処理
GetWindowRect(hPopupWnd, aRect);
if PtInRect(aRect, Point(X, Y)) then begin
Panel1.Caption := 'X: ' + IntToStr(X) + ' Y: ' + IntToStr(Y);
//マウスカーソルの移動の場合
if Message.WParam = WM_MOUSEMOVE then begin
//どの画像の位置にマウスカーソルがあるか調べる
NewImgIndex := -1;
for i := 0 to Length(RectImage) - 1 do begin
if PtInRect(RectImage[i], Point(X, Y)) then begin
NewImgIndex := i;
break;
end;
end;
//画像のメニュー項目以外の場合は再描画しない
//マウスカーソルの移動の度に再描画すると，チラつくことになる
//マウスカーソルが別の画像に移動したら再描画する
if (NewImgIndex <> CurrentImgIndex) then begin
CurrentImgIndex := NewImgIndex;
Flags := RDW_INVALIDATE or RDW_UPDATENOW;
RedrawWindow(hPopupWnd, nil, 0, Flags);
end;
end;
end else begin
if hPopupWnd <> 0 then Panel1.Caption := '';
end;
end;
//-----------------------------------------------------------------------------
// PopupMenu内部のPopupListのメッセージ処理
// WM_ENTERMENULOOP : PopupMenuを表示した時のメッセージ
// WM_EXITMENULOOP : PopupMenuが閉じた時のメッセージ
// これらのメッセージを受信したら，アプリのアクティブなフォーﾑにメッセージを送る
//-----------------------------------------------------------------------------
{ TPopupListEx }
procedure TPopupListEx.WndProc(var Message: TMessage);
begin
if Screen.Activeform <> nil then begin
if Message.Msg = WM_ENTERMENULOOP then begin
Screen.ActiveForm.Perform(WM_ENTERMENULOOP, Message.WParam, Message.LParam);
end else
if Message.Msg = WM_EXITMENULOOP then begin
Screen.ActiveForm.Perform(WM_EXITMENULOOP, Message.WParam, Message.LParam);
end;
end;
inherited;
end;
initialization
Popuplist.Free;
PopupList:= TPopupListEx.Create;
end.
|
