2

从历史上看，Delphi 的“视图”下拉菜单有大量项目。使用 Delphi XE2 加上几个必要的插件，这个数字变得有点大，几乎不适合我的屏幕高度。Windows 支持的普通 TMainMenu 可以适应这种情况并提供滚动或包装功能。不幸的是，RAD Studio 的主菜单似乎是 TActionMainMenuBar 无法处理的。

我能用它做什么？请指教。如果我再添加一个创建视图菜单项的加载项，它将开始重新定位下拉菜单并在鼠标释放时产生恶意点击。多了两个或三个项目，就会有一个不可见的项目:-(

4

2 回答 2

6

您可以尝试以下方法（将此单元添加到设计包中并将其安装在 IDE 中）。它找到 IDE 主窗体的 ActionManager 并将其样式设置为自定义样式，该样式为弹出菜单定义了一个新类。如果它们通常不适合屏幕，则此弹出菜单类会包装其菜单项：

包装菜单

unit TestUnit1;

interface

procedure InitializeStyle;

implementation

uses
  System.Types, System.Classes, System.SysUtils,
  Winapi.Messages, Winapi.Windows,
  Vcl.GraphUtil, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ActnMan, Vcl.ActnMenus, Vcl.StdActnMenus, Vcl.ActnCtrls,
  Vcl.PlatformDefaultStyleActnCtrls;

type
  THackCustomActionMenuBar = class(TCustomActionMenuBar);

  TStandardMenuPopupEx = class(TStandardMenuPopup)
  protected
    procedure AlignControls(AControl: TControl; var Rect: TRect); override;
    procedure CustomAlignPosition(Control: TControl; var NewLeft, NewTop, NewWidth, NewHeight: Integer;
      var AlignRect: TRect; AlignInfo: TAlignInfo); override;
    procedure PositionPopup(AnOwner: TCustomActionBar; ParentItem: TCustomActionControl); override;
    procedure WMKeyDown(var Message: TWMKey); override;
  public
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  end;

  TPlatformDefaultStyleActionBarsEx = class(TPlatformDefaultStyleActionBars)
  public
    function GetPopupClass(ActionBar: TCustomActionBar): TCustomPopupClass; override;
    function GetStyleName: string; override;
  end;

{ TStandardMenuPopupEx }

var
  NextLeft, NextTop: Integer;

procedure TStandardMenuPopupEx.AlignControls(AControl: TControl; var Rect: TRect);
begin
  NextLeft := 0;
  NextTop := 0;
  inherited AlignControls(AControl, Rect);
end;

procedure TStandardMenuPopupEx.CustomAlignPosition(Control: TControl; var NewLeft, NewTop, NewWidth, NewHeight: Integer;
  var AlignRect: TRect; AlignInfo: TAlignInfo);
var
  ScreenPos: TPoint;
begin
  inherited CustomAlignPosition(Control, NewLeft, NewTop, NewWidth, NewHeight, AlignRect, AlignInfo);
  NewLeft := NextLeft;
  NewTop := NextTop;
  NextTop := NewTop + NewHeight;

  ScreenPos := ClientToScreen(Point(NewLeft, NewTop));
  if ScreenPos.Y + NewHeight > Screen.MonitorFromPoint(ScreenPos).Height then
  begin
    NextTop := 0;
    Inc(NextLeft, NewWidth);
  end;
end;

procedure TStandardMenuPopupEx.PositionPopup(AnOwner: TCustomActionBar; ParentItem: TCustomActionControl);
var
  Popup: TStandardMenuPopupEx;
begin
  inherited PositionPopup(AnOwner, ParentItem);
  if (ParentItem.Parent is TStandardMenuPopupEx) then
  begin
    Popup := TStandardMenuPopupEx(ParentItem.Parent);
    if Assigned(Popup.Selected) and Assigned(Popup.Selected.Control) then
      Left := Popup.ClientToScreen(Popup.Selected.Control.BoundsRect.BottomRight).X - 6;
  end;
end;

procedure TStandardMenuPopupEx.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
  ScreenPos: TPoint;
  MonitorHeight: Integer;
begin
  ScreenPos := ClientToScreen(Point(ALeft, ATop));
  MonitorHeight := Screen.MonitorFromPoint(ScreenPos).Height;
  if ScreenPos.Y + AHeight > MonitorHeight then
    AHeight := MonitorHeight - ScreenPos.Y;

  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  if HandleAllocated then
    RequestAlign;
end;

procedure TStandardMenuPopupEx.WMKeyDown(var Message: TWMKey);
var
  NextPos: TPoint;
  Sibling: TControl;
begin
  case Message.CharCode of
    VK_RIGHT:
      if Assigned(Selected) and not Selected.HasItems and Assigned(Selected.Control) then
      begin
        NextPos := Point(Selected.Control.BoundsRect.Right + 1, Selected.Control.BoundsRect.Top);
        Sibling := ControlAtPos(NextPos, False);
        if Assigned(Sibling) then
        begin
          SelectItem(Sibling as TCustomActionControl);
          Exit;
        end;
      end;
    VK_LEFT:
      if Assigned(Selected) and not Selected.HasItems and Assigned(Selected.Control) then
      begin
        NextPos := Point(Selected.Control.BoundsRect.Left - 1, Selected.Control.BoundsRect.Top);
        Sibling := ControlAtPos(NextPos, False);
        if Assigned(Sibling) then
        begin
          SelectItem(Sibling as TCustomActionControl);
          Exit;
        end;
      end;
  end;
  inherited;
end;

{ TPlatformDefaultStyleActionBarsEx }

function TPlatformDefaultStyleActionBarsEx.GetPopupClass(ActionBar: TCustomActionBar): TCustomPopupClass;
begin
  if ActionBar is TCustomActionToolBar then
    Result := inherited GetPopupClass(ActionBar)
  else
    Result := TStandardMenuPopupEx;
end;

function TPlatformDefaultStyleActionBarsEx.GetStyleName: string;
begin
  Result := 'Platform Default Ex (with wrapping menus)';
end;

function FindMainActionManager: TActionManager;
var
  I: Integer;
begin
  Result := nil;
  if Assigned(Application) and Assigned(Application.MainForm) then
    for I := 0 to Application.MainForm.ComponentCount - 1 do
      if Application.MainForm.Components[I] is TActionManager then
      begin
        Result := TActionManager(Application.MainForm.Components[I]);
        Break;
      end;
end;

var
  ExStyle: TPlatformDefaultStyleActionBarsEx = nil;

procedure InitializeStyle;
var
  ActionManager: TActionManager;
begin
  ActionManager := FindMainActionManager;
  if Assigned(ActionManager) then
  begin
    ExStyle := TPlatformDefaultStyleActionBarsEx.Create;
    ActionManager.Style := ExStyle;
  end;
end;

procedure FinalizeStyle;
var
  ActionManager: TActionManager;
begin
  if not Assigned(ExStyle) then
    Exit;
  ActionManager := FindMainActionManager;
  if Assigned(ActionManager) then
  begin
    ActionManager.Style := PlatformDefaultStyle;
    FreeAndNil(ExStyle);
  end;
end;

initialization
  InitializeStyle;

finalization
  FinalizeStyle;

end.
于 2012-09-15T13:35:33.017 回答
3

根据Winspector，XE2 的主菜单是TActionMainMenuBar. （不幸的是，由于 Winspector 的工作方式，无法使用 Snagit 获取屏幕截图。）

我能想到的解决方案只有三个：

  1. 安装更少的“必要的插件”（您显然会考虑并拒绝）。

  2. 获得支持更高屏幕分辨率的更大显示器，为您提供更多屏幕区域（您会再次考虑并拒绝）。

  3. 编写一个 IDE 插件，View使用ToolsAPI. GExperts并且JEDI JVcl具有用于访问现有菜单（并添加您自己的菜单）到您应该能够适应的 IDE 的示例代码。

于 2012-09-15T04:48:54.493 回答