delphi – TActionMainMenuBar,VCL-Styles和MDI按钮(最小化,关闭等)没有被设置样式.

我正在尝试制作TActionMainMenuBar显示风格的MDI按钮,就像TMainMenu一样.

有什么建议？我不能停止在这个项目中使用MDI.

解决方法

好的,首先这不是Vcl样式错误,这是一个VCL错误.即使禁用Vcl样式,也会出现此问题.

该问题位于TCustomMDIMenuButton.Paint方法中,该方法使用旧的DrawFrameControl WinAPi方法绘制标题按钮.

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

作为解决方法,您可以使用绕行修补此方法,然后使用StylesServices实现新的绘制方法.

只需将此单元添加到项目中即可.

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,@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,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.

结果将是