7

I'm trying to make TActionMainMenuBar display styled MDI buttons like a TMainMenu does.

VCL Styles problem

Any suggestions? I can't stop using MDI for this project.

Peter
  • 2,977
  • 1
  • 17
  • 29
Marcio Rodrigues
  • 126
  • 6
  • You could always stop using VCL styles....... – David Heffernan Jun 01 '13 at 20:57
  • MDI was spawned with the idea of a single parent window hosting multiple instances of the same class of "document", Frames allow you to do just that without the unnecessary hassle for the developer and the user. – Peter Jun 03 '13 at 08:25
  • Can you include a sample code to reproduce the issue? – RRUZ Jun 03 '13 at 15:20
  • @RRUZ , in IDE create new MDI application, add ActionManager & ActionMainMenuBar to main form, use Vcl Styles, run project and cascade new child form. – Peter Jun 03 '13 at 20:39
  • @RRUZ As Peter Vonča said. But you need to maximaze the child window. – Marcio Rodrigues Jun 03 '13 at 23:52

1 Answers1

12

Ok, first this is not a Vcl Styles bug, this is a VCL bug. This issue appears even if the Vcl Styles Are disabled.

enter image description here

enter image description here

The issue is located in the TCustomMDIMenuButton.Paint method which uses the old DrawFrameControl WinAPi method to draw the caption buttons.

procedure TCustomMDIMenuButton.Paint;
begin
  DrawFrameControl(Canvas.Handle, ClientRect, DFC_CAPTION,
    MouseStyles[MouseInControl] or ButtonStyles[ButtonStyle] or
    PushStyles[FState = bsDown]);
end;

As workaround you can patch this method using a detour and then implementing a new paint method using the StylesServices.

Just add this unit to your project.

unit PatchMDIButtons;

interface

implementation

uses
  System.SysUtils,
  Winapi.Windows,
  Vcl.Themes,
  Vcl.Styles,
  Vcl.ActnMenus;

type
  TCustomMDIMenuButtonClass= class(TCustomMDIMenuButton);

  TJumpOfs = Integer;
  PPointer = ^Pointer;

  PXRedirCode = ^TXRedirCode;
  TXRedirCode = packed record
    Jump: Byte;
    Offset: TJumpOfs;
  end;

  PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp;
  TAbsoluteIndirectJmp = packed record
    OpCode: Word;
    Addr: PPointer;
  end;

var
  PaintMethodBackup   : TXRedirCode;

function GetActualAddr(Proc: Pointer): Pointer;
begin
  if Proc <> nil then
  begin
    if (Win32Platform = VER_PLATFORM_WIN32_NT) and (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then
      Result := PAbsoluteIndirectJmp(Proc).Addr^
    else
      Result := Proc;
  end
  else
    Result := nil;
end;

procedure HookProc(Proc, Dest: Pointer; var BackupCode: TXRedirCode);
var
  n: NativeUInt;
  Code: TXRedirCode;
begin
  Proc := GetActualAddr(Proc);
  Assert(Proc <> nil);
  if ReadProcessMemory(GetCurrentProcess, Proc, @BackupCode, SizeOf(BackupCode), n) then
  begin
    Code.Jump := $E9;
    Code.Offset := PAnsiChar(Dest) - PAnsiChar(Proc) - SizeOf(Code);
    WriteProcessMemory(GetCurrentProcess, Proc, @Code, SizeOf(Code), n);
  end;
end;

procedure UnhookProc(Proc: Pointer; var BackupCode: TXRedirCode);
var
  n: NativeUInt;
begin
  if (BackupCode.Jump <> 0) and (Proc <> nil) then
  begin
    Proc := GetActualAddr(Proc);
    Assert(Proc <> nil);
    WriteProcessMemory(GetCurrentProcess, Proc, @BackupCode, SizeOf(BackupCode), n);
    BackupCode.Jump := 0;
  end;
end;


procedure PaintPatch(Self: TObject);
const
  ButtonStyles: array[TMDIButtonStyle] of TThemedWindow = (twMDIMinButtonNormal, twMDIRestoreButtonNormal, twMDICloseButtonNormal);
var
  LButton : TCustomMDIMenuButtonClass;
  LDetails: TThemedElementDetails;
begin
  LButton:=TCustomMDIMenuButtonClass(Self);
  LDetails := StyleServices.GetElementDetails(ButtonStyles[LButton.ButtonStyle]);
  StyleServices.DrawElement(LButton.Canvas.Handle, LDetails, LButton.ClientRect);
end;

procedure HookPaint;
begin
  HookProc(@TCustomMDIMenuButtonClass.Paint, @PaintPatch, PaintMethodBackup);
end;

procedure UnHookPaint;
begin
  UnhookProc(@TCustomMDIMenuButtonClass.Paint, PaintMethodBackup);
end;


initialization
 HookPaint;
finalization
 UnHookPaint;
end.

The result will be

enter image description here enter image description here

RRUZ
  • 134,889
  • 20
  • 356
  • 483
  • You are welcome, don' forget report this issue to the QC site http://qc.embarcadero.com/wc/qcmain.aspx – RRUZ Jun 04 '13 at 13:31