Jump to content
chkaufmann

TPopupMenu with group headers

Recommended Posts

Hi,

 

I would like to add group headers in a TPopupmenu. So I can create things like this:

image.jpeg.becb1592fae1300aa731486b365c475c.jpeg

 

Are there any properties I didn't find yet in the standard VCL? Or can I do that with some additional methods in a TPopupMenu subclass?

 

Christian

Share this post


Link to post
9 minutes ago, chkaufmann said:

Hi,

 

I would like to add group headers in a TPopupmenu. So I can create things like this:

Are there any properties I didn't find yet in the standard VCL? Or can I do that with some additional methods in a TPopupMenu subclass?

 

Christian

Menu.Break := mbBarbreak //mbbreak

 

example

 

      ScreenMenu.Break := mbBarBreak;
      ScreenMenu.Enabled := False;
     // ScreenMenu.Bitmap:= Image1.Picture.Bitmap; 
      ScreenMenu.Bitmap.LoadFromResourceName(HInstance,'BITMAP_3');
 

 

 

Share this post


Link to post

Ok I added a disabled item ("Bearbeiten") in this case, but it's still aligned with all other items. And setting the Break property just adds a vertical line on the left side:

image.png.2bf5325de0cf88703226ffba6fb8a0a7.png

 

So what do I have to do to align the "Bearbeiten" Text at the left and to change the text color/background?

 

Christian

Share this post


Link to post

More info.  


 

procedure TpfEngine.AddScreenMenuitems;
var
  tabpageCount: integer;      // used in menuclick handler and tag business
  ScreenMenu: TMenuitem;
begin
  menucount := 0;
  extendedTScount := 0;
  For tabPageCount:= 0 to ComponentCount - 1 do
   if Components[tabpageCount].ClassNameIs('TTabSheet')then
    if (Components[tabpageCount] as TTabSheet).TabVisible then
  begin
    inc(MenuCount);
    ScreenMenu:= TMenuItem.Create(self);
    ScreenMenu.caption:= (Components[tabPageCount]as TTabSheet).Caption;
    ScreenMenu.Tag:= tabPageCount;
    extendedTScount := ScreenMenu.Tag;
    ScreenMenu.onClick:= MenuScreenClick;
    // dirty patch
    if ScreenMenu.caption =  'Prime Mover' then
    begin
      ScreenMenu.Enabled := False;
      ScreenMenu.Bitmap.LoadFromResourceName(HInstance,'BITMAP_ST');//:= Image1.Picture.Bitmap;
    end;

   ....

  Screens.add(screenmenu)    // Screens:TMenuItem

end;

 

Edited by Pat Foley
insert code formatted

Share this post


Link to post

Add an OnDrawItem or OnAdvancedDrawItem event handler to these menu items with something like the following code:

  ACanvas.Font.Style := [TFontStyle.fsBold];
  ACanvas.TextRect(ARect, 1, 1, StripHotkey((Sender as TMenuItem).Caption));

As obviously styles are involved, you might have to take that into account, too.

  • Like 1

Share this post


Link to post
3 hours ago, Pat Foley said:

Menu.Break := mbBarbreak //mbbreak

That does not produce the requested effect.  That is used for creating multi-column menus, not multi-group menus.

17 minutes ago, Uwe Raabe said:

Add an OnDrawItem or OnAdvancedDrawItem event handler to these menu items

This is the correct solution.  Menus simply have no concept of groups, so "group headers" is accomplished by custom-drawing those menu items differently.

Edited by Remy Lebeau
  • Like 1

Share this post


Link to post

Thanks for all hints.

 

I created a subclass of TMenuItem and did an override of the AdvancedDrawItem method. In addition I set Enabled=False. Themes are not support, but I don't have that anyway in my application. But so far it looks fine:

 

image.png.85e305eb60284384f5e4bd8438c7874a.png

 

procedure TMenuGroupItem.AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState; TopLevel: Boolean);
begin
  ACanvas.Brush.Color := TColors.Silver.Lighten(50);
  ACanvas.FillRect(ARect);
  ACanvas.Font.Color := TColors.SysWindowText;
  ACanvas.TextRect(ARect, ARect.Left + 3, ARect.Top + 3, StripHotkey(Caption));
end;

 

Christian

  • Like 4

Share this post


Link to post
Guest
11 minutes ago, chkaufmann said:

Themes are not support

DO test your implementation with multimonitor DPI. All kinds. Fastidiously!

Share this post


Link to post

@chkaufmann This looks awesome!

 

Btw add Vcl.Themes to your uses list and use TStyleManager.ActiveStyle.GetStyleColor and GetStyleFontColor to add VCL style support to your code.

 

Questions, though:

- If you hover your mouse on the header does it get highlighted? I guess not because state is ignored in general but worth to ask...

- This is my bigger issue: clicking on a header will close the menu, right? Maybe this can be fixed by overriding protected methods of the TMenuItem / TPopupMenu

Share this post


Link to post

Both "problems" are solved by setting Enabled=False for the group header item. Like this the color never changes and clicks on it are ignored.

 

Christian

Share this post


Link to post

Nice idea, @chkaufmann and nglthach.


I had to change it around a little to get it to work, as I instantiate the menu items at runtime.

Since I don't assign an OnClick handler, I don't need to disable the entry.


I mucked around with colors for a while.
Currently using Bold White on DarkGrey which works "ok" for both light and dark themes.

 

image.thumb.png.0df36a3bee165ba6ba86793ad99fcc59.png

type
  TMenuItemGroup = class(TMenuItem)
  protected
    procedure DoAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
  public
    constructor Create(AOwner: TComponent); override;
  end;

constructor TMenuItemGroup.Create(AOwner: TComponent);
begin
  Inherited;
  OnAdvancedDrawItem := DoAdvancedDrawItem;
end;

procedure TMenuItemGroup.DoAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
begin
  ACanvas.Brush.Color := TColors.Darkgrey; // TColors.SysHighlight; // TColors.Darkblue;
  ACanvas.FillRect(ARect);
  ACanvas.Font.Color := TColors.White; // TColors.SysHighlightText; // TColors.White;
  ACanvas.Font.Style := [fsBold];
  ACanvas.TextRect(ARect, ARect.Left + 3, ARect.Top + 3, StripHotkey(Caption));
end;

 

  • Like 3

Share this post


Link to post
4 hours ago, Lars Fosdal said:

Since I don't assign an OnClick handler, I don't need to disable the entry.

Maybe you should disable the item anyway to prevent navigating to it using arrow keys.

  • Like 2

Share this post


Link to post

I ended up combining the code of @chkaufmann and @Lars Fosdal plus added the always-disabled property. The end result fully supports VCL styles and looks awesome!

 

image.png.24dbfb3db9f1edffc8d93b9cfea60ab1.png image.png.c2c322b1a072d35321eca2302ec5767b.pngimage.png.5acc5506b66c9ea8cedb604d492db7ea.png 

 

The full code became:

Unit uHeaderMenuItem;

Interface

Uses Vcl.Menus, Vcl.Graphics, WinApi.Windows, System.Classes;

Type
 THeaderMenuItem = Class(TMenuItem)
 strict private
  Procedure SetEnabled(Const inEnabled: Boolean);
  Function GetEnabled: Boolean;
 protected
  Procedure AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState; TopLevel: Boolean); Override;
  Procedure DoAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
  Procedure Loaded; Override;
 Public
  Constructor Create(AOwner: TComponent); Override;
 published
  Property Enabled: Boolean Read GetEnabled Write SetEnabled;
 End;

Implementation

Uses Vcl.Themes, System.SysUtils;

Procedure THeaderMenuItem.AdvancedDrawItem(ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState; TopLevel: Boolean);
Begin
 Self.DoAdvancedDrawItem(Self, ACanvas, ARect, State);
End;

Constructor THeaderMenuItem.Create(AOwner: TComponent);
Begin
 inherited;

 Self.Enabled := False;
 OnAdvancedDrawItem := DoAdvancedDrawItem;
End;

Procedure THeaderMenuItem.DoAdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
Begin
 ACanvas.Brush.Color := TStyleManager.ActiveStyle.GetStyleColor(scPanelDisabled);
 ACanvas.FillRect(ARect);
 ACanvas.Font.Color := TStyleManager.ActiveStyle.GetStyleFontColor(sfWindowTextNormal);
 ACanvas.Font.Style := [fsBold];
 ACanvas.TextRect(ARect, ARect.Left + 3, ARect.Top + 3, StripHotkey(Caption));
End;

Function THeaderMenuItem.GetEnabled: Boolean;
Begin
 Result := inherited Enabled;
End;

Procedure THeaderMenuItem.Loaded;
Begin
 inherited;

 Self.Enabled := False;
End;

Procedure THeaderMenuItem.SetEnabled(Const inEnabled: Boolean);
Begin
 inherited Enabled := False;
End;

End.

  • Like 4
  • Thanks 5

Share this post


Link to post

Does anyone know what is the name of Delphi's menueditor? I only could find it in FMX but I guess I should be looking at the VCL version.

It would be nice to extend it so it is capable of adding header items.

Share this post


Link to post
25 minutes ago, David Duffy said:

Is TStyleManager available in Delphi XE ?

No, it was introduced in XE2.

Share this post


Link to post

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now

×