Skip to content

Instantly share code, notes, and snippets.

@freeonterminate

freeonterminate/uFMXMenu.pas

Last active December 27, 2015 23:49
Show Gist options
  • Save freeonterminate/7408947 to your computer and use it in GitHub Desktop.
Save freeonterminate/7408947 to your computer and use it in GitHub Desktop.
Download ZIP
TMenuBar を使った Menu の問題を修正します。詳しくはソース先頭のコメントをご覧ください。似た問題として QC#119282 と QC#101866 があります。
Raw
uFMXMenu.pas
{
■概要
TMenuBar を使った Main Menu の次の問題を修正します。
1.マルチディスプレイで Form の X 座標がマイナス座標の時、
メニューが座標 0, y に表示されてしまう問題
2. OnMouseDown でメニューが選択されてしまう問題（通常は OnMouseUp で選択）
ただし厳密な動作検証はしていないので、ちょっとおかしな動作をするかもしれません。
■使用方法
uFMXMenuUtils.pas を uses するだけで、修正されます。
}
unit uFMXMenuUtils;
interface
implementation
uses
System.UITypes, System.Classes, System.Generics.Collections, System.Types
, FMX.Types, FMX.Platform, FMX.Forms, FMX.Controls, FMX.Menus
{$IFDEF MSWINDOWS}
, FMX.Platform.Win, Winapi.Windows, Winapi.Messages, Winapi.ActiveX
{$ENDIF}
;
type
TMenuService = class(TInterfacedObject, IFMXMenuService)
protected
procedure StartMenuLoop(const AView: IMenuView);
function ShortCutToText(ShortCut: TShortCut): String;
procedure ShortCutToKey(
ShortCut: TShortCut;
var Key: Word;
var Shift: TShiftState);
function TextToShortCut(Text: String): Integer;
procedure CreateOSMenu(
AForm: TCommonCustomForm;
const AMenu: IItemsContainer);
procedure UpdateMenuItem(
const AItem: IItemsContainer;
AChange: TMenuItemChanges);
procedure DestroyMenuItem(const AItem: IItemsContainer);
function IsMenuBarOnWindowBorder: Boolean;
procedure UpdateMenuBar;
{$IFDEF MSWINDOWS}
private
FPleaseEnd: Boolean;
FPopupForms: TList<TCustomPopupForm>;
procedure PopupFormDestroy(Sender: TObject);
protected
procedure WindowsMenuLoop(const AView: IMenuView);
{$ENDIF}
end;
var
GOrgMenuService: IFMXMenuService = nil;
GMenuService: TMenuService;
procedure FixMenuItemClick;
begin
if (GOrgMenuService <> nil) then
Exit;
TPlatformServices.Current.SupportsPlatformService(
IFMXMenuService,
IInterface(GOrgMenuService));
if (GOrgMenuService = nil) then
Exit;
GMenuService := TMenuService.Create;
TPlatformServices.Current.RemovePlatformService(IFMXMenuService);
TPlatformServices.Current.AddPlatformService(IFMXMenuService, GMenuService);
end;
{ TMenuService }
procedure TMenuService.CreateOSMenu(
AForm: TCommonCustomForm;
const AMenu: IItemsContainer);
begin
GOrgMenuService.CreateOSMenu(AForm, AMenu);
end;
procedure TMenuService.DestroyMenuItem(const AItem: IItemsContainer);
begin
GOrgMenuService.DestroyMenuItem(AItem);
end;
function TMenuService.IsMenuBarOnWindowBorder: Boolean;
begin
Result := GOrgMenuService.IsMenuBarOnWindowBorder;
end;
{$IFDEF MSWINDOWS}
procedure TMenuService.PopupFormDestroy(Sender: TObject);
begin
if (Sender is TCustomPopupForm) then
FPopupForms.Remove(TCustomPopupForm(Sender));
end;
{$ENDIF}
procedure TMenuService.ShortCutToKey(
ShortCut: TShortCut;
var Key: Word;
var Shift: TShiftState);
begin
GOrgMenuService.ShortCutToKey(ShortCut, Key, Shift);
end;
function TMenuService.ShortCutToText(ShortCut: TShortCut): String;
begin
GOrgMenuService.ShortCutToText(ShortCut);
end;
procedure TMenuService.StartMenuLoop(const AView: IMenuView);
begin
{$IFDEF MSWINDOWS}
WindowsMenuLoop(AView);
{$ELSE}
GOrgMenuService.StartMenuLoop(AView);
{$ENDIF}
end;
function TMenuService.TextToShortCut(Text: String): Integer;
begin
Result := GOrgMenuService.TextToShortCut(Text);
end;
procedure TMenuService.UpdateMenuBar;
begin
GOrgMenuService.UpdateMenuBar;
end;
procedure TMenuService.UpdateMenuItem(
const AItem: IItemsContainer;
AChange: TMenuItemChanges);
begin
GOrgMenuService.UpdateMenuItem(AItem, AChange);
end;
{$IFDEF MSWINDOWS}
type
TOpenMenuItem = class(TMenuItem);
procedure TMenuService.WindowsMenuLoop(const AView: IMenuView);
var
FirstLoop: Boolean;
procedure EndLoop;
var
View: IMenuView;
begin
View := AView;
while View <> nil do
begin
View.Loop := False;
View.Selected := nil;
View := View.ParentView;
end;
FPopupForms.Clear;
end;
function ContinueLoop: Boolean;
begin
Result := AView.Loop;
end;
function ForwardSelectNextMenuItem(AView: IMenuView; AStartInd, AEndInd: Integer): Boolean;
var
I: Integer;
begin
if not Assigned(AView) then
Exit(False);
Result := False;
for I := AStartInd to AEndInd do
if AView.GetItem(I) is TMenuITem then
begin
AView.Selected := TMenuItem(AView.GetItem(I));
Result := True;
Break;
end;
end;
function BackwardSelectNextMenuItem(AView: IMenuView; AStartInd, AEndInd: Integer): Boolean;
var
I: Integer;
begin
if not Assigned(AView) then
Exit(False);
Result := False;
for I := AStartInd downto AEndInd do
if AView.GetItem(I) is TMenuItem then
begin
AView.Selected := TMenuItem(AView.GetItem(I));
Result := True;
Break;
end;
end;
procedure SelectFirstMenuItem(AView: IMenuView);
begin
ForwardSelectNextMenuItem(AView, 0, AView.GetItemsCount - 1);
end;
procedure SelectLastMenuItem(AView: IMenuView);
begin
BackwardSelectNextMenuItem(AView, AView.GetItemsCount - 1, 0);
end;
procedure SelectPrevMenuItem(AView: IMenuView);
begin
if not Assigned(AView) then
Exit;
if Assigned(AView.Selected) then
begin
{ Select first Menu item from old selected to first }
if BackwardSelectNextMenuItem(AView, AView.Selected.Index - 1, 0) then
Exit;
{ Select first Menu item from last to old selected }
BackwardSelectNextMenuItem(AView, AView.GetItemsCount - 1, AView.Selected.Index);
end
else
SelectLastMenuItem(AView);
end;
procedure SelectNextMenuItem(AView: IMenuView);
begin
if not Assigned(AView) then
Exit;
if Assigned(AView.Selected) then
begin
{ Select first Menu item from old selected to last }
if ForwardSelectNextMenuItem(AView, AView.Selected.Index + 1, AView.GetItemsCount - 1) then
Exit;
{ Select first Menu item from first to old selected }
ForwardSelectNextMenuItem(AView, 0, AView.Selected.Index);
end
else
SelectFirstMenuItem(AView);
end;
var
Msg: TMsg;
WP: TPoint;
P: TPointF;
InMenus: Boolean;
CurrentView, NewView: IMenuView;
Obj: IControl;
TimerId: THandle;
PopupForm: TCustomPopupForm;
Popup: TPopup;
Last: TCustomPopupForm;
Index: Integer;
Left: Integer;
PV: IMenuView;
Item: TControl;
Pos: TPointF;
begin
PopupForm := nil;
Left := 0;
AView.Loop := True;
TimerId := SetTimer(0, 0, 50, nil);
try
FirstLoop := True;
while ContinueLoop do
begin
//--- FIXED case Form.Left < 0
//--- START
if (PopupForm = nil) then begin
if (FPopupForms = nil) then
FPopupForms := TList<TCustomPopupForm>.Create;
Index := Screen.PopupFormCount - 1;
PV := AView.ParentView;
if (Index > -1) and (PV <> nil) then begin
PopupForm := TCustomPopupForm(Screen.PopupForms[Index]);
PopupForm.OnDestroy := PopupFormDestroy;
if (PopupForm.PlacementTarget is TMenuItem) then begin
Popup := AView.Parent as TPopup;
Item := PopupForm.PlacementTarget as TMenuItem;
Pos := PV.LocalToScreen(Item.Position.Point);
if (FPopupForms.Count > 0) then begin
Last := FPopupForms.Last;
Pos.X := Last.Left + Last.Width - Popup.BorderWidth * 2;
end;
Pos.X := Pos.X - Popup.BorderWidth;
Left := Trunc(Pos.X);
FPopupForms.Add(PopupForm);
end;
end;
PopupForm.Left := Left;
end
else
PopupForm.Left := Left;
//--- END
if FirstLoop then
FirstLoop := False
else
WaitMessage;
while ContinueLoop and PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) do
begin
case Msg.message of
WM_WINDOWPOSCHANGING:
begin
EndLoop;
Exit;
end;
WM_QUIT{, WM_NCLBUTTONDOWN..WM_NCMBUTTONDBLCLK}:
begin
EndLoop;
Continue;
end;
WM_TIMER:
begin
TranslateMessage(Msg);
end;
end;
if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
begin
case Msg.message of
WM_CONTEXTMENU: ;
WM_NCMOUSEMOVE, WM_NCLBUTTONDOWN, WM_NCLBUTTONUP:
begin
case Msg.message of
WM_NCMOUSEMOVE: begin
{ Handle MouseOver }
{$IFDEF CPUX64}
WP := SmallPointToPoint(TSmallPoint(Cardinal(Msg.lParam)));
{$ELSE}
WP := SmallPointToPoint(TSmallPoint(Msg.lParam));
{$ENDIF}
P := PointF(WP.X, WP.Y);
Obj := AView.ObjectAtPoint(P);
TranslateMessage(Msg);
DispatchMessage(Msg);
{ Find top level menu }
CurrentView := AView;
while CurrentView.ParentView <> nil do
CurrentView := CurrentView.ParentView;
{ Check all items }
while CurrentView <> nil do
begin
Obj := CurrentView.ObjectAtPoint(P);
if (Obj <> nil) and (Obj.GetObject is TMenuItem) and not (TMenuItem(Obj.GetObject).IsSelected) then
begin
if (CurrentView <> AView) then
begin
NewView := AView;
while NewView <> CurrentView do
begin
NewView.Loop := False;
NewView := NewView.ParentView;
end;
TOpenMenuItem(Obj.GetObject).NeedPopup;
Exit;
end;
end;
CurrentView := CurrentView.ChildView;
end;
Continue;
end;
WM_NCLBUTTONDOWN: begin
{ Handle MouseOver if mouse over not menuitem }
{$IFDEF CPUX64}
WP := SmallPointToPoint(TSmallPoint(Cardinal(Msg.lParam)));
{$ELSE}
WP := SmallPointToPoint(TSmallPoint(Msg.lParam));
{$ENDIF}
P := PointF(WP.X, WP.Y);
Obj := AView.ObjectAtPoint(P);
if (Obj <> nil) and not (Obj is TMenuItem) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
Continue;
end;
{ Menus }
if (Obj <> nil) and (Obj.GetObject is TMenuItem) then
begin
if not (TMenuItem(Obj.GetObject).IsSelected) and TMenuItem(Obj.GetObject).HavePopup then
TOpenMenuItem(Obj.GetObject).NeedPopup
else
begin
EndLoop;
TOpenMenuItem(Obj.GetObject).Click;
end;
end
else
begin
CurrentView := AView;
InMenus := False;
while (CurrentView <> nil) and not InMenus do
begin
if not (CurrentView.IsMenuBar) and (CurrentView.ObjectAtPoint(P) <> nil) then
InMenus := True;
CurrentView := CurrentView.ParentView;
end;
if not InMenus then
EndLoop;
end;
end;
WM_NCLBUTTONUP: begin
{ Handle MouseOver if mouse over not menuitem }
{$IFDEF CPUX64}
WP := SmallPointToPoint(TSmallPoint(Cardinal(Msg.lParam)));
{$ELSE}
WP := SmallPointToPoint(TSmallPoint(Msg.lParam));
{$ENDIF}
P := PointF(WP.X, WP.Y);
Obj := AView.ObjectAtPoint(P);
if (Obj <> nil) and not (Obj is TMenuItem) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
Continue;
end;
end;
end;
end;
WM_MOUSEFIRST..WM_MOUSELAST:
begin
case Msg.message of
WM_MOUSEMOVE: begin
TranslateMessage(Msg);
DispatchMessage(Msg);
Continue;
end;
WM_LBUTTONDOWN: begin
{ Handle MouseOver if mouse over not menuitem }
{$IFDEF CPUX64}
WP := SmallPointToPoint(TSmallPoint(Cardinal(Msg.lParam)));
{$ELSE}
WP := SmallPointToPoint(TSmallPoint(Msg.lParam));
{$ENDIF}
Winapi.Windows.ClientToScreen(Msg.hwnd, WP);
P := PointF(WP.X, WP.Y);
Obj := AView.ObjectAtPoint(P);
if (Obj <> nil) and not (Obj is TMenuItem) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
Continue;
end;
{ Menus }
if (Obj <> nil) and (Obj.GetObject is TMenuItem) then
begin
if not (TMenuItem(Obj.GetObject).IsSelected) and TMenuItem(Obj.GetObject).HavePopup then
TOpenMenuItem(Obj.GetObject).NeedPopup
else
begin
//--- FIXED EndLoop when mouse down
//--- START
FPleaseEnd := True
//EndLoop;
//TOpenMenuItem(Obj.GetObject).Click;
//--- END
end;
end
else
begin
CurrentView := AView;
InMenus := False;
while (CurrentView <> nil) and not InMenus do
begin
if not (CurrentView.IsMenuBar) and (CurrentView.ObjectAtPoint(P) <> nil) then
InMenus := True;
CurrentView := CurrentView.ParentView;
end;
if not InMenus then
EndLoop;
end;
end;
WM_LBUTTONUP: begin
//--- FIXED EndLoop when mouse down
//--- START
if (FPleaseEnd) then begin
FPleaseEnd := False;
EndLoop;
TOpenMenuItem(Obj.GetObject).Click;
end;
//--- END
{ Handle MouseOver if mouse over not menuitem }
{$IFDEF CPUX64}
WP := SmallPointToPoint(TSmallPoint(Cardinal(Msg.lParam)));
{$ELSE}
WP := SmallPointToPoint(TSmallPoint(Msg.lParam));
{$ENDIF}
Winapi.Windows.ClientToScreen(Msg.hwnd, WP);
P := PointF(WP.X, WP.Y);
Obj := AView.ObjectAtPoint(P);
if (Obj <> nil) and not (Obj is TMenuItem) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
Continue;
end;
end;
end;
end;
WM_KEYFIRST..WM_KEYLAST:
if (GetKeyState(VK_LBUTTON) >= 0) then
case Msg.message of
WM_KEYDOWN, WM_SYSKEYDOWN:
case Msg.wParam of
VK_TAB:
begin
end;
VK_RETURN:
begin
if (AView.Selected <> nil) then
begin
if AView.Selected.HavePopup then
AView.Selected.NeedPopup
else
begin
TOpenMenuItem(AView.Selected).Click;
EndLoop;
end;
end
else
EndLoop;
end;
VK_SPACE:
begin
end;
VK_ESCAPE:
begin
AView.Selected := nil;
Exit;
end;
VK_MENU, VK_F10:
EndLoop;
VK_LEFT:
begin
if AView.IsMenuBar then
begin
SelectPrevMenuItem(AView);
end
else
if (AView.ParentView <> nil) then
if (AView.ParentView.IsMenuBar) then
begin
AView.Loop := False;
SelectPrevMenuItem(AView.ParentView);
if AView.ParentView.Selected <> nil then
AView.ParentView.Selected.NeedPopup;
Exit;
end
else
begin
AView.Loop := False;
end;
end;
VK_RIGHT:
begin
if AView.IsMenuBar then
begin
SelectNextMenuItem(AView);
end
else
begin
if (AView.ParentView <> nil) then
if (AView.ParentView.IsMenuBar) then
begin
AView.Loop := False;
SelectNextMenuItem(AView.ParentView);
if AView.ParentView.Selected <> nil then
AView.ParentView.Selected.NeedPopup;
Exit;
end
else
begin
AView.Loop := False;
end;
end;
end;
VK_UP:
if not AView.IsMenuBar then
SelectPrevMenuItem(AView);
VK_DOWN:
if not AView.IsMenuBar then
SelectNextMenuItem(AView)
else
if AView.Selected <> nil then
AView.Selected.NeedPopup;
end;
WM_CHAR, WM_SYSCHAR: ;
end;
else
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
end;
end;
finally
KillTimer(0, TimerId);
AView.Loop := False;
Winapi.Windows.ReleaseCapture;
end;
end;
{$ENDIF}
initialization
begin
FixMenuItemClick;
end;
finalization
begin
end;
end.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment