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;