How to create popup menu with scroll bar that also supports sub-menus

Question

I want to add scroll bars (and/or scroll wheel support) to my existing Delphi application's popup menus, because they are often higher than the screen, and the built in scrolling is not good enough. How to make a popup menu with scrollbar? would be a great solution for me, except that it doesn't support sub-menus, which I absolutely require. The author of that solution hasn't been on StackOverflow since last July, so I don't think he'll reply to my comment. Can anyone see how to modify that code to add support for sub-menus? In case it matters, I need it to work with Delphi 2007.

I thought the TListBox is what adds the scrollbar, though. TMainMenu doesn't have a scrollbar, as far as I know. — matthewk, Jan 12 '17 at 16:48
It's a sign from above. Find a better UI paradigm than a popup menu! — David Heffernan, Jan 12 '17 at 17:05
Forget my earlier comments. If you are considering rolling your own solution, you might take a look at the freeware TVirtualTreeView as a starting point - see http://www.soft-gems.net/index.php/controls/virtual-treeview — MartynA, Jan 12 '17 at 17:47
Thanks. Do you think it's impossible to add support for sub-menus to the linked solution, then? That would be my preferred approach. — matthewk, Jan 12 '17 at 17:54
That code is based on creating a form with a Listbox that pretends to be a menu (and thus provides scrollbars). There's no way to get a Listbox to pop up a submenu or child Listbox, so you'll have to come up with one yourself. Although a) if you have popup menus that are that big, your UI needs some serious redesign (my users would revolt), and b) if you want to break from the standard UI controls to work in your vastly oversized menus, you should be prepared to roll up your sleeves and write the code to do it instead of expecting others to do it for you. — Ken White, Jan 12 '17 at 18:18
You are referring to a post that use a listbox. What you want is, in effect, a popup listbox with sub-listbox support, not a popup menu with sub-menu support. I wouldn't say it to be impossible, definitely not worth the effort though.. — Sertac Akyuz, Jan 12 '17 at 18:18
As a user I would despise having to use this program. Surely you can do better. — David Heffernan, Jan 12 '17 at 20:50

MartynA · Accepted Answer · 2017-01-12T20:19:14.830

I share @KenWhite's reservations about how users might receive a huge menu. So apologies to him and readers whose sensibilities the following might offend ;=)

Anyway, I hope the code below shows that in principle, it is straightforward to create a TreeView based on a TPopUpMenu (see the routine PopUpMenuToTree) which reflects the structure of the PopUpMenu, including sub-items, and make use of the TreeView's automatic vertical scroll bar. In the code, the PopUpMenu happens to be on the same form as the TreeView, but that's only for compactness, of course - the PopUpMenu could be on anothe form entirely.

As mentioned in a comment, personally I would base something like this on a TVirtualTreeView (http://www.soft-gems.net/index.php/controls/virtual-treeview) because it is far more customisable than a standard TTreeView.

type
  TForm1 = class(TForm)
    PopupMenu1: TPopupMenu;
    TreeView1: TTreeView;  //  alClient-aligned
    Start1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure TreeView1Click(Sender: TObject);
  private
  protected
    procedure MenuItemClick(Sender : TObject);
    procedure PopUpMenuToTree(PopUpMenu : TPopUpMenu; TreeView : TTreeView);
  public
  end;

var
  Form1: TForm1;

[...]

procedure TForm1.FormCreate(Sender: TObject);
var
  Item,
  SubItem : TMenuItem;
  i,
  j : Integer;
begin
  //  (Over)populate a PopUpMenu
  for i := 1 to 50 do begin
    Item := TMenuItem.Create(PopUpMenu1);
    Item.Caption := 'Item ' + IntToStr(i);
    Item.OnClick := MenuItemClick;
    PopUpMenu1.Items.Add(Item);
    for j := 1 to 5 do begin
      SubItem := TMenuItem.Create(PopUpMenu1);
      SubItem.Caption := Format('Item %d Subitem %d ', [i, j]);
      SubItem.OnClick := MenuItemClick;
      Item.Add(SubItem);
    end;
  end;

  //  Populate a TreeView from the PopUpMenu
  PopUpMenuToTree(PopUpMenu1, TreeView1);
end;

procedure TForm1.MenuItemClick(Sender: TObject);
var
  Item : TMenuItem;
begin
  if Sender is TMenuItem then
    Caption := TMenuItem(Sender).Caption + ' clicked';
end;

procedure TForm1.PopUpMenuToTree(PopUpMenu: TPopUpMenu;
  TreeView: TTreeView);
//  Populates the TreeView with the Items in the PopUpMenu
var
  i : Integer;
  Item : TMenuItem;
  RootNode : TTreeNode;

  procedure AddItem(Item : TMenuItem; ParentNode : TTreeNode);
  var
    Node : TTreeNode;
    j : Integer;
  begin
    Node := TreeView.Items.AddChildObject(ParentNode, Item.Caption, Item);
    for j := 0 to Item.Count - 1 do begin
      AddItem(Item.Items[j], Node);
    end;
  end;

begin
  TreeView.Items.BeginUpdate;
  TreeView.Items.Clear;
  try
    for i := 0 to PopUpMenu.Items.Count - 1 do begin
      AddItem(PopUpMenu.Items[i], Nil);
    end;
  finally
    TreeView.Items.EndUpdate;
  end;
end;

procedure TForm1.TreeView1Click(Sender: TObject);
var
  Node : TTreeNode;
  Item : TMenuItem;
begin
  if Sender is TTreeView then begin
    Node := TTreeView(Sender).Selected;
    Item := TMenuItem(Node.Data);
    Item.Click;
  end;
end;

Thank you so much for this, I think it could be a really good solution for my application. I am working on it now and will post the finished code when it's done. — matthewk, Jan 13 '17 at 11:17
I have now accepted it, and thanks again, but for anyone else looking for the actual finished solution, see the code I posted separately. — matthewk, Jan 16 '17 at 10:47

score 1 · Answer 2 · edited May 23 '17 at 12:16

Here's what I have done, by merging How to make a popup menu with scrollbar?, MartynA's code, and some of my own:

unit PopupUnit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  StdCtrls, Menus, ComCtrls;

type
  TPopupMode = (pmStandard, pmCustom);
  TPopupMenu = class(Menus.TPopupMenu)
  private
    FPopupForm: TForm;
    FPopupMode: TPopupMode;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Popup(X, Y: Integer); override;
    property PopupForm: TForm read FPopupForm write FPopupForm;
    property PopupMode: TPopupMode read FPopupMode write FPopupMode;
  end;

type
  TPopupForm = class(TForm)
  private
    FPopupForm: TForm;
    FPopupMenu: TPopupMenu;
    FTreeView: TTreeView;
    procedure DoResize;
    procedure TreeViewClick(Sender: TObject);
    procedure TreeViewCollapsedOrExpanded(Sender: TObject; Node: TTreeNode);
    procedure TreeViewKeyPress(Sender: TObject; var Key: Char);
    procedure WMActivate(var AMessage: TWMActivate); message WM_ACTIVATE;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent; APopupForm: TForm;
      APopupMenu: TPopupMenu); reintroduce;
  end;

var
  PopupForm: TPopupForm;

implementation

{$R *.dfm}

{ TPopupForm }

constructor TPopupForm.Create(AOwner: TComponent; APopupForm: TForm;
  APopupMenu: TPopupMenu);

  procedure AddItem(Item : TMenuItem; ParentNode : TTreeNode);
  var
    I : Integer;
    Node : TTreeNode;
  begin
    if Item.Caption <> '-' then begin
      Node := FTreeView.Items.AddChildObject(ParentNode, Item.Caption, Item);
      Node.ImageIndex := Item.ImageIndex;
      for I := 0 to Item.Count - 1 do begin
        AddItem(Item.Items[I], Node);
      end;
    end;
  end;

var
  I: Integer;
begin
  inherited Create(AOwner);
  BorderStyle := bsNone;

  FPopupForm := APopupForm;
  FPopupMenu := APopupMenu;

  FTreeView := TTreeView.Create(Self);
  FTreeView.Parent := Self;
  FTreeView.Align := alClient;
  FTreeView.BorderStyle := bsSingle;
  FTreeView.Color := clMenu;
  FTreeView.Images := FPopupMenu.Images;
  FTreeView.ReadOnly := TRUE;
  FTreeView.ShowHint := FALSE;
  FTreeView.ToolTips := FALSE;
  FTreeView.OnClick := TreeViewClick;
  FTreeView.OnCollapsed := TreeViewCollapsedOrExpanded;
  FTreeView.OnExpanded := TreeViewCollapsedOrExpanded;
  FTreeView.OnKeyPress := TreeViewKeyPress;

  FTreeView.Items.BeginUpdate;
  try
    FTreeView.Items.Clear;
    for I := 0 to FPopupMenu.Items.Count - 1 do
    begin
      AddItem(FPopupMenu.Items[I], NIL);
    end;
  finally
    FTreeView.Items.EndUpdate;
  end;
  DoResize;
end;

procedure TPopupForm.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;

procedure TPopupForm.DoResize;
const
  BORDER = 2;
var
  ItemRect, TVRect : TRect;
  MF : TForm;
  Node : TTreeNode;
begin
  TVRect := Rect(0, 0, 0, 0);
  Node := FTreeView.Items[0];
  while Node <> NIL do begin
    ItemRect := Node.DisplayRect(TRUE);
    ItemRect.Right := ItemRect.Right + FTreeView.Images.Width + 1;
    if ItemRect.Left < TVRect.Left then
      TVRect.Left := ItemRect.Left;
    if ItemRect.Right > TVRect.Right then
      TVRect.Right := ItemRect.Right;
    if ItemRect.Top < TVRect.Top then
      TVRect.Top := ItemRect.Top;
    if ItemRect.Bottom > TVRect.Bottom then
      TVRect.Bottom := ItemRect.Bottom;
    Node := Node.GetNextVisible;
  end;
  MF := Application.MainForm;
  if Top + TVRect.Bottom - TVRect.Top > MF.Top + MF.ClientHeight then begin
    TVRect.Bottom := TVRect.Bottom -
      (Top + TVRect.Bottom - TVRect.Top - (MF.Top + MF.ClientHeight));
  end;
  if Left + TVRect.Right - TVRect.Left > MF.Left + MF.ClientWidth then begin
    TVRect.Right := TVRect.Right -
      (Left + TVRect.Right - TVRect.Left - (MF.Left + MF.ClientWidth));
  end;
  ClientHeight := TVRect.Bottom - TVRect.Top + BORDER * 2;
  ClientWidth := TVRect.Right - TVRect.Left + BORDER * 2;
end;

procedure TPopupForm.TreeViewClick(Sender: TObject);
var
  Node : TTreeNode;
  Item : TMenuItem;
begin
  if Sender is TTreeView then begin
    Node := TTreeView(Sender).Selected;
    if assigned(Node) then begin
      Item := TMenuItem(Node.Data);
      if assigned(Item.OnClick) then begin
        Item.Click;
        Close;
      end;
    end;
  end;
end;

procedure TPopupForm.TreeViewCollapsedOrExpanded(Sender: TObject;
  Node: TTreeNode);
begin
  DoResize;
end;

procedure TPopupForm.TreeViewKeyPress(Sender: TObject; var Key: Char);
begin
  if Ord(Key) = VK_RETURN then begin
    TreeViewClick(Sender);
  end
  else if Ord(Key) = VK_ESCAPE then begin
    Close;
  end;
end;

procedure TPopupForm.WMActivate(var AMessage: TWMActivate);
begin
  SendMessage(FPopupForm.Handle, WM_NCACTIVATE, 1, 0);
  inherited;
  if AMessage.Active = WA_INACTIVE then
    Release;
  FTreeView.Select(NIL, []);
end;

{ TPopupMenu }

constructor TPopupMenu.Create(AOwner: TComponent);
begin
  inherited;
  FPopupMode := pmStandard;
end;

procedure TPopupMenu.Popup(X, Y: Integer);
begin
  case FPopupMode of
    pmCustom:
    with TPopupForm.Create(nil, FPopupForm, Self) do
    begin
      Top := Y;
      Left := X;
      Show;
    end;
    pmStandard: inherited;
  end;
end;

end.

How to create popup menu with scroll bar that also supports sub-menus

2 Answers2

Linked

Related