Here is my fix for TPlatformDefaultStyleActionBars .
Most of the code is simply copied from standard units except for TFixedThemedMenuItemStyle.DoDrawMenuCheck .
Note that you must also override TXPStyleMenuItem if you want to run your software on an OS prior to Vista.
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 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;