メニュー項目を移動するには？
解決スタートボタンをクリックすると表示されるポップアップメニュー内の項目は
ドラッグすることによって移動できますが、同じような処理を TPopupMenu で
実現できないでしょうか？
または、実現できているコンポーネントがないでしょうか？
（同じ質問が約５年前にあったのですが、解決できなかったようで・・・）
環境は、D5，D6，XP，Win7です。
宜しくお願い致します。
TPopupMenuでは難しいようですね。
出来なくはないような気がするけど、やっぱり出来なさそう。
と考えていたので答えるのを躊躇してました。
ポップアップするFormを作り
PanelをalTopにしてたくさん並べて
MouseMoveで色を変化させて
Drag&Dropで移動する。
そんなPopupMenuっぽいUIを実装する必要がありそうです。
タイマーを使った力業。
D6 XP SP3
とりあえずメニューアイテムを3つくらい作ってOnClickイベントにN1OnClickを割り当ててテスト。
private
{ Private 宣言 }
F_DragItem: TMenuItem;
procedure TForm1.PopupMenu1Popup(Sender: TObject);
begin
F_DragItem := nil;
Timer1.Enabled := True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
i: Integer;
l_MenuItem: TMenuItem;
lpt_Pos: TPoint;
lrc_Rect: TRect;
begin
GetMenuItemRect(0, PopupMenu1.Handle, 0, lrc_Rect);
if ((lrc_Rect.Right - lrc_Rect.Left) <= 0)
or ((lrc_Rect.Bottom - lrc_Rect.Top) <= 0)
then begin
//ポップアップメニューは非表示
Timer1.Enabled := False;
end;
if (gfnbKeyState(VK_LBUTTON))
and (F_DragItem = nil)
then begin
//ドラッグ開始かも知れない
lpt_Pos := gfnptMousePosGet;
for i := 0 to PopupMenu1.Items.Count-1 do begin
l_MenuItem := PopupMenu1.Items[i];
GetMenuItemRect(0, PopupMenu1.Handle, i, lrc_Rect);
if (PtInRect(lrc_Rect, lpt_Pos)) then begin
F_DragItem := l_MenuItem;
Timer1.Enabled := False;
Exit
end;
end;
end;
end;
procedure TForm1.N1Click(Sender: TObject);
var
l_MenuItem: TMenuItem;
begin
l_MenuItem := TMenuItem(Sender);
if (F_DragItem <> nil)
and (F_DragItem <> l_MenuItem)
then begin
//並べ替え
F_DragItem.MenuIndex := l_MenuItem.MenuIndex;
end;
end;
訂正と追加。
>OnClickイベントにN1OnClickを割り当ててテスト。
OnClickイベントにN1Clickを割り当ててテスト。
function gfnbKeyState(iKey: Integer): Boolean;
var
li_Check: SHORT;
begin
//左右ボタンを入れ替えている場合に対処
if (GetSystemMetrics(SM_SWAPBUTTON) <> 0) then begin
if (iKey = VK_LBUTTON) then begin
iKey := VK_RBUTTON;
end else if (iKey = VK_RBUTTON) then begin
iKey := VK_LBUTTON;
end;
end;
li_Check := GetAsyncKeyState(iKey);
Result := BOOL(Hi(li_Check));
end;
失礼。もう一つ追加。
function gfnptMousePosGet: TPoint;
//マウスカーソルの位置をスクリーン座標で返す
begin
Result := Point(0, 0);
GetCursorPos(Result);
end;
Fusa様、Ｄ様、ありがとうございます。
Fusa様の方法はちょっと実装が辛そうです（＾＾；
Ｄ様の方法を試してみました。
ちょっと挙動が変でしたが、一応移動ができました。
（移動している最中では移動しているように見えないときがあるけど、
実際は移動している）
ただ、サブメニューへの・からの、移動はこれではできないようで、
ちょっと色々試してみようと思います。
ありがとうございました。
1) サブメニューへ移動するとメニューが消える
2) サブメニューを持ってる項目に移動すると消える時と消えないときがある
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls, ExtCtrls, Menus;
type
TPopupList = class(Menus.TPopupList)
public
procedure WndProc(var Message: TMessage); override;
end;
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
N221: TMenuItem;
N34451: TMenuItem;
N54351: TMenuItem;
Memo1: TMemo;
N61: TMenuItem;
N111: TMenuItem;
N121: TMenuItem;
N131: TMenuItem;
N211: TMenuItem;
N222: TMenuItem;
N231: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure PopupMenu1Popup(Sender: TObject);
private
{ Private 宣言 }
protected
public
{ Public 宣言 }
end;
const
WH_MOUSE_LL = 14;
var
Form1: TForm1;
PopupList2 : TPopupList;
SelectMenuID,DragSelectMenuID,DropSelectMenuID: Integer;
isPopup : Boolean;
isMouseDown: Boolean;
isDragDrop : Boolean;
SelectPopupMenu: TPopupMenu;
DragMenuItem,DropMenuItem: TMenuItem;
implementation
{$R *.DFM}
var
MouseHookHandle : HHOOK;
procedure TPopupList.WndProc(var Message: TMessage);
begin
inherited;
case Message.Msg of
WM_ENTERMENULOOP://$0211;
begin
SelectMenuID := -1;
DragSelectMenuID := -2;
IsPopup := True;
isMouseDown := False;
isDragDrop := False;
DropMenuItem := nil;
DragMenuItem := nil;
end;
WM_MENUSELECT: //$11F
begin
SelectMenuID := Message.WParamLo;
end;
WM_EXITMENULOOP://$0212;
begin
isPopup := False;
end;
end;
end;
procedure GetMenuItemRect(Value: TComponent; Index: Integer; var Result: TMenuItem);
var
Rect: TRect;
P: TPoint;
begin
P := Point(0, 0);
GetCursorPos(P);
if Value is TPopupMenu then
begin
Windows.GetMenuItemRect(0, TPopupMenu(Value).Handle, Index, Rect);
if (PtInRect(Rect, P)) then
begin
Result := TPopupMenu(Value).Items[Index]
end;
end;
if Value is TMenuItem then
begin
Windows.GetMenuItemRect(0 , TMenuItem(Value).Parent.Handle , Index, Rect);
if (PtInRect(Rect, P)) then
begin
Result := TMenuItem(Value).Parent.Items[Index];
end;
end;
end;
procedure GetMenuItem(Value: TComponent; Index: Integer; var Result: TMenuItem);
var
I,J: Integer;
begin
if Value is TPopupMenu then
begin
for I:=0 to TPopupMenu(Value).Items.Count -1 do
begin
if Assigned(Result) = False then
begin
GetMenuItemRect (Value,I,Result);
for J:=0 to TPopupMenu(Value).Items[I].Count - 1 do
begin
GetMenuItem(TPopupMenu(Value).Items[I].Items[J],J,Result);
end;
end;
end;
end;
if Value is TMenuItem then
begin
if Assigned(Result) = False then
begin
GetMenuItemRect (Value,Index,Result);
for I:=0 to TMenuItem(Value).Count -1 do
begin
GetMenuItem(TMenuItem(Value).Items[I],I,Result);
end;
end;
end;
end;
function MouseHook(nCode: Integer; WParam: wParam; LParam: lParam): Integer; stdcall;
function _GetMenuItem: TMenuItem;
begin
Result := nil;
if Assigned(SelectPopupMenu) = True then
begin
GetMenuItem(SelectPopupMenu,0,Result);
end;
end;
procedure ButtonDown;
begin
DragSelectMenuID := SelectMenuID;
isMouseDown := True;
isDragDrop := False;
DragMenuItem := _GetMenuItem;
end;
procedure ButtonUp;
var
MI: TMenuItem;
isParent: Boolean;
begin
Windows.SetCursor(Screen.Cursors[crDefault]);
if isDragDrop = True then
begin
DropSelectMenuID := SelectMenuID;
if DragSelectMenuID <> DropSelectMenuID then
begin
DropMenuItem := _GetMenuItem;
if (Assigned(DragMenuItem) = True) and (Assigned(DropMenuItem) = True) then
begin
if DragMenuItem.Parent = DropMenuItem.Parent then
begin
if DropMenuItem.MenuIndex <> DragMenuItem.MenuIndex then
begin
DragMenuItem.MenuIndex := DropMenuItem.MenuIndex;
end
end
else
begin
isParent := False;
MI := DropMenuItem;
while MI <> SelectPopupMenu.Items do
begin
if DragMenuItem = MI then isParent := True;
MI := MI.Parent;
end;
if isParent = False then
begin
DragMenuItem.Parent.Delete(DragMenuItem.MenuIndex);
DropMenuItem.Parent.Insert(DropMenuItem.MenuIndex,DragMenuItem);
end
else
begin
//子や孫にはコピーできない
end;
end;
end;
Result := 1;
end;
end;
isMouseDown := False;
end;
begin
Result := 0;
if IsPopup = True then
begin
if nCode = HC_ACTION then
begin
case WParam of
WM_LBUTTONDOWN:
begin
if (GetSystemMetrics(SM_SWAPBUTTON) = 0) then ButtonDown;
end;
WM_RBUTTONDOWN:
begin
if (GetSystemMetrics(SM_SWAPBUTTON) <> 0) then ButtonDown;
end;
WM_MOUSEMOVE:
begin
if isMouseDown = True then
begin
SetCursor(Screen.Cursors[crDrag]);
isDragDrop := True;
end;
end;
WM_LBUTTONUP:
begin
if (GetSystemMetrics(SM_SWAPBUTTON) = 0) then ButtonUp;
if isDragDrop = True then Result := 1;
end;
WM_RBUTTONUP:
begin
if (GetSystemMetrics(SM_SWAPBUTTON) <> 0) then ButtonUp;
if isDragDrop = True then Result := 1;
end;
end;
end;
end;
if Result = 0 then
begin
Result := CallNextHookEx(MouseHookHandle, nCode, wParam, lParam);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
I: Integer;
begin
PopupList2 := TPopupList(PopupList);
PopupList := TPopupList.Create;
for I:=0 to PopupList2.Count -1 do
begin
PopupList.Add(TPopupMenu(PopupList2.Get(I)));
end;
MouseHookHandle := SetWindowsHookEx(WH_MOUSE_LL,@MouseHook,hInstance,0);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
PopupList.Free;
PopupList := TPopupList(PopupList2);
UnhookWindowsHookEx(MouseHookHandle);
end;
procedure TForm1.PopupMenu1Popup(Sender: TObject);
begin
SelectPopupMenu := PopupMenu1;
end;
end.
KHE00221様、ありがとうございました。
内容は全く分からないのですが、そのままコードを書いたところ、
D5,XPでは問題なく移動が出来ました。サブメニューの、への移動も完璧です。
これでプログラミングの幅が増えました。感謝しております。
これから理解に移ろうと思います（＾＾；
ただ、右上のボタン（最小化、最大化、終了）をクリックしますと、
約５秒位無反応でマウスカーソルも移動できず、その後正常な動作に移ります。
でも、ボタンを追加してクリックイベントでClose;などを実行すれば
すぐ反応するので問題ないと言えば問題ないのですが・・・。
フックの開始と終了のタイミングを
WM_ENTERMENULOOP と WM_EXITMENULOOP に
変更すれば直るかな
KHE00221様
上記のようにタイミングを変更すると無反応が無くなりました。
これで全く問題なく使用できます。ありがとうございました。
| ツイート |  |