Overly tall "View" dropdown menu in XE2

Question

Historically Delphi's View dropdown has substantial number of items. With Delphi XE2 plus several necessary add-ins this number became marginally large and barely fitting my screen height. Normal TMainMenu backed by Windows can accommodate this case and provide either scrolling or wrapping capability. Unfortunately, it looks like RAD Studio's main menu is TActionMainMenuBar which cannot deal with that.

What can i do with that? Please advise. If I add just one more add-in which creates View menu item, it will start repositioning dropdown menu and producing rogue click upon mouse release. With two or three items more there will be an invisible item :-(

Ondrej Kelle Ondrej Kelle · Accepted Answer · 2012-09-15T13:35:33

You could try the following (add this unit to a design package and install it in the IDE). It finds the IDE main form's ActionManager and sets its style to a custom style which defines a new class for popup menus. This popup menu class wraps its menu items if they normally wouldn't fit on screen:

Wrapping menu

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.

Overly tall "View" dropdown menu in XE2

2 Answers