Search code examples
delphistylesthemesribbonvcl

Delphi - change ribbon menu color when VCL theme is applied

I'm using TRibbon on an Delphi XE7 application with VCL theme applied and I'd like to change the menu color (because it's difficult to see the items in dark themes), as following:

with theme

I've tried the following code, but it only works when style is disabled:

  Ribbon1.ApplicationMenu.Menu.ColorMap.MenuColor:= clYellow;

without theme

Also no effect with this line:

  Ribbon1.ApplicationMenu.Menu.ColorMap.MenuColor:= StyleServices.GetStyleColor(scButtonHot);

Does anyone know if it is possible? Thanks a lot!

Solution

  • After some try, I found a solution. I don't know if it's the best approach, but it worked for me and could be useful for someone else.

    The problem is the method bellow (Vcl.ActnMenus.pas), when StyleServices is enabled:

    procedure TCustomActionPopupMenu.DrawBackground;
begin
  inherited;
  if StyleServices.Enabled and not StyleServices.IsSystemStyle then
    StyleServices.DrawElement(Canvas.Handle, StyleServices.GetElementDetails(tmPopupBackground),
      Rect(0, 0, Width, Height))
  else
  begin
    Canvas.Brush.Color := ColorMap.MenuColor;
    Canvas.FillRect(ClientRect);
  end;
end;

    So, in order to bypass this method, I just hooked it (adapting from here):

    unit MethodHooker;

interface

uses Windows, Vcl.ActnMenus;

type
  PInstruction = ^TInstruction;
  TInstruction = packed record
    Opcode: Byte;
    Offset: Integer;
  end;

  TCustomActionPopupMenu = class(Vcl.ActnMenus.TCustomActionPopupMenu)
    procedure DrawBackgroundEx;
  end;

implementation

procedure Patch(Address: Pointer; const NewCode; Size: NativeUInt);
var
  NumberOfBytes: NativeUInt;
begin
  WriteProcessMemory(GetCurrentProcess, Address, @NewCode, Size, NumberOfBytes);
end;

procedure Redirect(OldAddress, NewAddress: Pointer);
var
  NewCode: TInstruction;
begin
  NewCode.Opcode := $E9;//jump relative
  NewCode.Offset := Integer(NewAddress)-Integer(OldAddress)-SizeOf(NewCode);
  Patch(OldAddress, NewCode, SizeOf(NewCode));
end;

{ TCustomActionPopupMenu }

procedure TCustomActionPopupMenu.DrawBackgroundEx;
begin
  Canvas.Brush.Color := $00EEEAE9;
  Canvas.FillRect(ClientRect);
end;

initialization
  Redirect(@TCustomActionPopupMenu.DrawBackground, @TCustomActionPopupMenu.DrawBackgroundEx);

end.

    That's it. Just save this unit and add it to the project. No need to call this anywhere.