ポップアップメニューを表示して，そのメニューのウィンドウの上で
マウスの右ボタンクリックで，別のポップアップメニューを表示するサンプルです．
(1) 新規にプロジェクトを作成して，保存します．
(2) Delphi のソースコードの Menu.pas をプロジェクトのフォルダにコピーします．
(3) Menu.pas に，以下の 1 行を追加します．
TPM_RECURSE を追加すると右クリックで閉じなくなります．
procedure TPopupMenu.Popup(X, Y: Integer);
...
...
AFlags := AFlags or TPM_RECURSE; //追加
TrackPopupMenu(FItems.Handle, AFlags, X, Y, 0 { reserved }, PopupList.Window, nil);
end;
(4) TPopupMenu コンポを 2 つフォームに配置して，適当に項目を作成します．
(5) TPanel コンポを 1 つ配置します．
(5) Form1 の PopupMenu プロパティを PopupMenu1 にします．
(6) テスト用のコードを以下のようにします．
面白そうなので，サブのポップアップメニューをいくつでも表示できるようにして
います．
動作確認は，Windows 7 U64(SP1) + Delphi XE(UP1) Pro です．
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Menus;
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;
Panel1: TPanel;
PopupMenu2: TPopupMenu;
Item_20: TMenuItem;
Item_21: TMenuItem;
Item_22: TMenuItem;
Item_23: TMenuItem;
private
{ Private 宣言 }
protected
procedure WMExitMenuLoop(var Message: TWMExitMenuLoop);
message WM_EXITMENULOOP;
procedure WMEnterMenuLoop(var Message: TWMEnterMenuLoop);
message WM_ENTERMENULOOP;
procedure WMMenuSelect(var Message: TWMMenuSelect);
message WM_MENUSELECT;
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));
//PopupMenuのOnClickイベントを使用しない場合はResult := -1にしてExit;
//このコードにすると，TMenuItem.OnClickは検出できなくなる
Result := -1;
exit;
end;
Result := CallNextHookEx(hMouseHook, nCode, wPar, lPar);
end;
end;
//-----------------------------------------------------------------------------
// PopupMenuが表示された時のメッセージ処理
// マウスフックを開始する
//-----------------------------------------------------------------------------
procedure TForm1.WMEnterMenuLoop(var Message: TWMEnterMenuLoop);
begin
if hMouseHook = 0 then begin
hMouseHook := SetWindowsHookEx(WH_MOUSE, @MouseHookProc, 0, GetCurrentThreadID);
end;
end;
//-----------------------------------------------------------------------------
// PopupMenuが閉じた時のメッセージ処理
// マウスフックを終了して，PopupMeneを全て閉じる
//-----------------------------------------------------------------------------
procedure TForm1.WMExitMenuLoop(var Message: TWMExitMenuLoop);
var
MousePos : TPoint;
begin
GetCursorPos(MousePos);
//1つでも閉じれば全て閉じることにする
SendMessage(Handle, WM_APP+100, WM_LBUTTONUP, MakeLParam(MousePos.X, MousePos.Y));
if hMouseHook <> 0 then begin
UnhookWindowsHookEx(hMouseHook);
hMouseHook := 0;
end;
end;
//-----------------------------------------------------------------------------
// PopupMenuで項目を選択された時のメッセージ処理
// 選択されている項目名を表示
// 実際に選択したかで項目を取得するには，WM_LBUTTONUPがいいかも知れない
// ただし，どの項目を選択したかは，このWM_MENUSELECTまたは
// TPopupList.WndProc内でないと取得は困難だろう
//-----------------------------------------------------------------------------
procedure TForm1.WMMenuSelect(var Message: TWMMenuSelect);
var
i : Integer;
MenuItem : TMenuItem;
begin
if (Message.MenuFlag = $FFFF) and (Message.Menu = 0) then exit;
Panel1.Caption := '';
for i := 0 to ComponentCount - 1 do begin
if Components[i].ClassName = 'TPopupMenu' then begin
if TPopupMenu(Components[i]).Handle = Message.Menu then begin
MenuItem := TPopupMenu(Components[i]).FindItem(Message.IDItem, fkCommand);
Panel1.Caption := MenuItem.Name;
Break;
end;
end;
end;
end;
//-----------------------------------------------------------------------------
// ローカルマウスフックのメッセージを受信
//-----------------------------------------------------------------------------
procedure TForm1.WMApp100(var Message: TMessage);
var
X : Integer;
Y : Integer;
hPopupWnd : HWND;
begin
X := LOWORD(Message.LParam);
Y := HIWORD(Message.LParam);
//左ボタンUP(項目を選択した時)はTPopupMenuを全て閉じることにする
if (Message.WParam = WM_LBUTTONUP) then begin
while True do begin
hPopupWnd := FindWindow('#32768', nil);
if hPopupWnd = 0 then break;
SendMessage(hPopupWnd, WM_CLOSE, 0, 0);
Application.ProcessMessages;
Sleep(1);
end;
end else
//右ボタンUPでは新しくTPopupMenuを表示する
if (Message.WParam = WM_RBUTTONUP) then begin
PopupMenu2.Popup(X, Y);
end;
end;
//-----------------------------------------------------------------------------
// PopupMenu内部のPopupListのメッセージ処理
// これらのメッセージを受信したら，アプリのアクティブなフォームにメッセージを送る
//-----------------------------------------------------------------------------
{ 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;
if Message.Msg = WM_MENUSELECT then begin
Screen.ActiveForm.Perform(WM_MENUSELECT, Message.WParam, Message.LParam);
end;
end;
inherited;
end;
initialization
Popuplist.Free;
PopupList:= TPopupListEx.Create;
end.
下図は，設計時と実行した画面です．
Panel1 に，(左ボタンDOWNまたは矢印キー等で)選択の項目名を表示します．
 |