RadioItems in menu on TActionMainMenuBar - delphi

Question

I use the TActionMainMenuBar to show menu based on TActions.
I grouped the actions by setting the same GroupIndex. So they can operate like RadioGroup, but the problem is that there are checks is drawn instead of radio buttons.
Is there any way to change that?

Answer 1

Here is my fix for TPlatformDefaultStyleActionBars.
Most of the code just copied from standard units, except TFixedThemedMenuItemStyle.DoDrawMenuCheck.
Note you must override also TXPStyleMenuItem if you want to run your software on pre-Vista OS.
uses
// ... add these units
StdStyleActnCtrls, XPStyleActnCtrls, XPActnCtrls, ImgList, Types, Themes,
StdActnMenus, ThemedActnCtrls, ListActns, UxTheme;
type
TFixedThemedMenuItemStyle = class(TThemedMenuItem)
private
FCheckRect: TRect;
FGutterRect: TRect;
FPaintRect: TRect;
FSubMenuGlyphRect: TRect;
FSeparatorHeight: Integer;
procedure DoDrawMenuCheck;
procedure DoDrawText(DC: HDC; const Text: string; var Rect: TRect; Flags: Longint);
protected
procedure DrawGlyph(const Location: TPoint); override;
public
procedure CalcBounds; override;
end;
TFixedPlatformDefaultStyleActionBars = class(TPlatformDefaultStyleActionBars)
public
function GetControlClass(ActionBar: TCustomActionBar;
AnItem: TActionClientItem): TCustomActionControlClass; override;
function GetStyleName: string; override;
end;
TForm1 = class(TForm)
ActionMainMenuBar1: TActionMainMenuBar;
ActionManager1: TActionManager;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
Style: TFixedPlatformDefaultStyleActionBars;
public
end;
implementation
procedure TForm1.FormCreate(Sender: TObject);
begin
Style := TFixedPlatformDefaultStyleActionBars.Create();
ActionManager1.Style := Style;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Style.Free();
end;
procedure TFixedThemedMenuItemStyle.CalcBounds;
const
CheckMarkStates: array[Boolean] of Integer =
(MC_CHECKMARKDISABLED, MC_CHECKMARKNORMAL);
SubMenuStates: array[Boolean] of Integer = (MSM_DISABLED, MSM_NORMAL);
var
DC: HDC;
LFont: HFONT;
LTheme: HTheme;
LBounds: TRect;
LImageSize: TPoint;
LHeight, LWidth, Offset: Integer;
LGlyphSize, LGutterSize, LSeparatorSize, LSubMenuGlyphSize: TSize;
LCheckMargins, LGutterMargins, LMenuItemMargins, LSeparatorMargins, LSubMenuGlyphMargins: TMargins;
begin
// Fill in parent object's private fields.
inherited;
DC := CreateCompatibleDC(0);
try
LFont := SelectObject(DC, Screen.MenuFont.Handle);
try
Font.Assign(Screen.MenuFont);
inherited;
LTheme := ThemeServices.Theme[teMenu];
LHeight := 0;
LWidth := 0;
// Check/Glyph
GetThemePartSize(LTheme, DC, MENU_POPUPCHECK,
CheckMarkStates[Enabled], nil, TS_TRUE, LGlyphSize);
GetThemeMargins(LTheme, DC, MENU_POPUPCHECK,
CheckMarkStates[Enabled], TMT_CONTENTMARGINS, nil, LCheckMargins);
// Gutter
GetThemePartSize(LTheme, DC, MENU_POPUPGUTTER, 0, nil, TS_TRUE, LGutterSize);
GetThemeMargins(LTheme, DC, MENU_POPUPGUTTER, 0, TMT_SIZINGMARGINS, nil, LGutterMargins);
// Menu item
GetThemeMargins(LTheme, DC, MENU_POPUPITEM, MPI_NORMAL, TMT_SIZINGMARGINS, nil, LMenuItemMargins);
GetThemePartSize(LTheme, DC, MENU_POPUPSUBMENU, SubMenuStates[Enabled], nil, TS_TRUE, LSubMenuGlyphSize);
GetThemeMargins(LTheme, DC, MENU_POPUPSUBMENU, SubMenuStates[Enabled], TMT_CONTENTMARGINS, nil, LSubMenuGlyphMargins);
// Calculate check/glyph size
LImageSize := GetImageSize;
if LImageSize.Y > LGlyphSize.cy then
LGlyphSize.cy := LImageSize.Y;
if LImageSize.X > LGlyphSize.cx then
LGlyphSize.cx := LImageSize.X;
Inc(LHeight, LGlyphSize.cy);
Inc(LWidth, LGlyphSize.cx);
// Add margins for check/glyph
Inc(LHeight, LCheckMargins.cyTopHeight + LCheckMargins.cyBottomHeight);
Inc(LWidth, LCheckMargins.cxLeftWidth + LCheckMargins.cxRightWidth);
FCheckRect := Rect(0, 0,
LGlyphSize.cx + LCheckMargins.cxRightWidth + LCheckMargins.cxRightWidth,
LGlyphSize.cy + LCheckMargins.cyBottomHeight + LCheckMargins.cyBottomHeight);
// Add size and margins for gutter
Inc(LWidth, LGutterMargins.cxLeftWidth);
FGutterRect.Left := LWidth;
FGutterRect.Right := FGutterRect.Left + LGutterSize.cx;
Inc(LWidth, LGutterSize.cx + LGutterMargins.cxRightWidth);
// Add margins for menu item
Inc(LWidth, LMenuItemMargins.cxLeftWidth + LMenuItemMargins.cxRightWidth);
Offset := LWidth - TextBounds.Left - LMenuItemMargins.cxRightWidth;
LBounds := TextBounds;
OffsetRect(LBounds, Offset, -1);
TextBounds := LBounds;
// Add size of potential submenu glyph
Inc(LWidth, LSubMenuGlyphSize.cx);
Inc(LWidth, LSubMenuGlyphMargins.cxLeftWidth);
Inc(LWidth, LSubMenuGlyphMargins.cxRightWidth);
// Add Width of menu item to FSubMenuGlyphRect before using
FSubMenuGlyphRect := Rect(-LSubMenuGlyphMargins.cxRightWidth - LSubMenuGlyphSize.cx,
(Height - LSubMenuGlyphSize.cy) div 2,
-LSubMenuGlyphMargins.cxRightWidth,
((Height - LSubMenuGlyphSize.cy) div 2) + LSubMenuGlyphSize.cy);
// Add margins for menu short cut
if ActionClient <> nil then
begin
LBounds := Rect(0, 0, 0, 0);
DoDrawText(DC, ActionClient.ShortCutText, LBounds, DT_CALCRECT or DT_NOCLIP);
end
else
LBounds := ShortCutBounds;
Offset := FSubMenuGlyphRect.Left - LBounds.Right -
LMenuItemMargins.cxRightWidth - LSubMenuGlyphMargins.cxLeftWidth;
OffsetRect(LBounds, Offset, 0);
// Add Width of menu item to ShortCutBounds before using
ShortCutBounds := LBounds;
Inc(LWidth, LMenuItemMargins.cxLeftWidth + LMenuItemMargins.cxRightWidth);
// Adjust size if separator
if Separator then
begin
GetThemePartSize(LTheme, DC, MENU_POPUPSEPARATOR, 0, nil, TS_TRUE, LSeparatorSize);
GetThemeMargins(LTheme, DC, MENU_POPUPSEPARATOR, 0, TMT_SIZINGMARGINS, nil, LSeparatorMargins);
LHeight := LSeparatorSize.cy + LSeparatorMargins.cyBottomHeight;
LWidth := LSeparatorSize.cx;
FSeparatorHeight := LSeparatorSize.cy;
end;
FGutterRect.Top := 0;
FGutterRect.Bottom := LHeight;
SetBounds(Left, Top,
LWidth + TextBounds.Right - TextBounds.Left + ShortCutBounds.Right - ShortCutBounds.Left,
LHeight);
finally
SelectObject(DC, LFont);
end;
finally
DeleteDC(DC);
end;
end;
// THE ONLY SERIOUS DIFFERENCE: RENDERING BULLETS INSTEAD OF CHECKMARKS FOR RADIO ITEMS
procedure TFixedThemedMenuItemStyle.DoDrawMenuCheck;
const
CheckMarkBkgs: array[Boolean] of Integer = (MCB_DISABLED, MCB_NORMAL);
CheckMarkStates: array[Boolean] of Integer = (MC_CHECKMARKDISABLED, MC_CHECKMARKNORMAL);
RadioMarkStates: array[Boolean] of Integer = (MC_BULLETDISABLED, MC_BULLETNORMAL);
begin
if IsChecked then
begin
DrawThemeBackground(ThemeServices.Theme[teMenu], Canvas.Handle,
MENU_POPUPCHECKBACKGROUND, CheckMarkBkgs[Enabled], FCheckRect, nil);
if not HasGlyph then
begin
if IsGrouped then
begin
DrawThemeBackground(ThemeServices.Theme[teMenu], Canvas.Handle,
MENU_POPUPCHECK, RadioMarkStates[Enabled], FCheckRect, nil);
end
else
begin
DrawThemeBackground(ThemeServices.Theme[teMenu], Canvas.Handle,
MENU_POPUPCHECK, CheckMarkStates[Enabled], FCheckRect, nil);
end;
end;
end;
end;
procedure TFixedThemedMenuItemStyle.DoDrawText(
DC: HDC; const Text: string; var Rect: TRect; Flags: Integer);
const
MenuStates: array[Boolean] of Integer = (MPI_DISABLED, MPI_NORMAL);
var
Options: TDTTOpts;
begin
// Setup Options
{$IF NOT DEFINED(CLR)}
FillChar(Options, SizeOf(Options), 0);
Options.dwSize := SizeOf(Options);
{$ELSE}
Options.dwSize := Marshal.SizeOf(TypeOf(Options));
{$IFEND}
Options.dwFlags := DTT_TEXTCOLOR or DTT_COMPOSITED;
if Flags and DT_CALCRECT = DT_CALCRECT then
Options.dwFlags := Options.dwFlags or DTT_CALCRECT;
// Retrieve text color
GetThemeColor(ThemeServices.Theme[teMenu], MENU_POPUPITEM,
MenuStates[Enabled or ActionBar.DesignMode], TMT_TEXTCOLOR, Options.crText);
// Draw menu item text
DrawThemeTextEx(ThemeServices.Theme[teMenu], DC, MENU_POPUPITEM,
MenuStates[Enabled or ActionBar.DesignMode], Text, Length(Text), Flags, Rect, Options);
end;
procedure TFixedThemedMenuItemStyle.DrawGlyph(const Location: TPoint);
var
LImageSize, LLocation: TPoint;
begin
if (Action is TCustomAction) and TCustomAction(Action).Checked then
DoDrawMenuCheck;
if HasGlyph then
begin
LImageSize := GetImageSize;
LLocation.X := ((FCheckRect.Right - FCheckRect.Left) - LImageSize.X) div 2;
LLocation.Y := ((FCheckRect.Bottom - FCheckRect.Top) - LImageSize.Y) div 2;
inherited DrawGlyph(LLocation);
end;
end;
type
TActionControlStyle = (csStandard, csXPStyle, csThemed);
function GetActionControlStyle: TActionControlStyle;
begin
if Win32MajorVersion >= 6 then
begin
if ThemeServices.Theme[teMenu] <> 0 then
Result := csThemed
else
Result := csXPStyle;
end
else
if CheckWin32Version(5, 1) then
Result := csXPStyle
else
Result := csStandard;
end;
function TFixedPlatformDefaultStyleActionBars.GetControlClass(ActionBar: TCustomActionBar;
AnItem: TActionClientItem): TCustomActionControlClass;
begin
if ActionBar is TCustomActionToolBar then
begin
if AnItem.HasItems then
case GetActionControlStyle of
csStandard: Result := TStandardDropDownButton;
csXPStyle: Result := TXPStyleDropDownBtn;
else
Result := TThemedDropDownButton;
end
else
if (AnItem.Action is TStaticListAction) or
(AnItem.Action is TVirtualListAction) then
Result := TCustomComboControl
else
case GetActionControlStyle of
csStandard: Result := TStandardButtonControl;
csXPStyle: Result := TXPStyleButton;
else
Result := TThemedButtonControl;
end
end
else if ActionBar is TCustomActionMainMenuBar then
case GetActionControlStyle of
csStandard: Result := TStandardMenuButton;
csXPStyle: Result := TXPStyleMenuButton;
else
Result := TThemedMenuButton;
end
else if ActionBar is TCustomizeActionToolBar then
begin
with TCustomizeActionToolbar(ActionBar) do
if not Assigned(RootMenu) or
(AnItem.ParentItem <> TCustomizeActionToolBar(RootMenu).AdditionalItem) then
case GetActionControlStyle of
csStandard: Result := TStandardMenuItem;
csXPStyle: Result := TXPStyleMenuItem;
else
Result := TFixedThemedMenuItemStyle;
end
else
case GetActionControlStyle of
csStandard: Result := TStandardAddRemoveItem;
csXPStyle: Result := TXPStyleAddRemoveItem;
else
Result := TThemedAddRemoveItem;
end
end
else if ActionBar is TCustomActionPopupMenu then
case GetActionControlStyle of
csStandard: Result := TStandardMenuItem;
csXPStyle: Result := TXPStyleMenuItem;
else
Result := TFixedThemedMenuItemStyle;
end
else
case GetActionControlStyle of
csStandard: Result := TStandardButtonControl;
csXPStyle: Result := TXPStyleButton;
else
Result := TThemedButtonControl;
end
end;
function TFixedPlatformDefaultStyleActionBars.GetStyleName: string;
begin
Result := 'My fixed platform style';
end;