TActionMainMenuBar，VCL样式和MDI按钮（最小化，关闭等）不被设置。

问题描述

任何建议？我不能停止对这个项目使用MDI。

解决方案

好的，首先这不是一个Vcl风格的错误，这是一个VCL错误。即使Vcl风格被禁用，也会出现此问题。

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

 程序TCustomMDIMenuButton.Paint; 
 begin 
 DrawFrameControl（Canvas.Handle，ClientRect，DFC_CAPTION，
 MouseStyles [MouseInControl]或ButtonStyles [ButtonStyle]或
 PushStyles [FState = bsDown]）; 
结束
  

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

只需将此单位添加到您的项目中。

  unit PatchMDIButtons; 
 
接口
 
实现
 
使用
 System.SysUtils，
 Winapi.Windows，
 Vcl.Themes ，
 Vcl.Styles，
 Vcl.ActnMenus; 
 
 type 
 TCustomMDIMenuButtonClass = class（TCustomMDIMenuButton）; 
 
 TJumpOfs =整数; 
 PPointer = ^指针; 
 
 PXRedirCode = ^ TXRedirCode; 
 TXRedirCode =打包记录
 Jump：Byte; 
偏移量：TJumpOfs; 
结束
 
 PAbsoluteIndirectJmp = ^ TAbsoluteIndirectJmp; 
 TAbsoluteIndirectJmp =打包记录
 OpCode：Word; 
地址：PPointer; 
结束
 
 var 
 PaintMethodBackup：TXRedirCode; 
 
函数GetActualAddr（Proc：Pointer）：指针; 
 begin 
如果Proc<>然后
 begin 
 if（Win32Platform = VER_PLATFORM_WIN32_NT）和（PAbsoluteIndirectJmp（Proc）.OpCode = $ 25FF）然后
结果：= PAbsoluteIndirectJmp（Proc）.Addr ^ 
 else 
结果：= Proc; 
 end 
 else 
结果：= nil; 
结束
 
程序HookProc（Proc，Dest：Pointer; var BackupCode：TXRedirCode）; 
 var 
 n：NativeUInt; 
代码：TXRedirCode; 
 begin 
 Proc：= GetActualAddr（Proc）; 
 Assert（Proc<> nil）; 
如果ReadProcessMemory（GetCurrentProcess，Proc，@BackupCode，SizeOf（BackupCode），n）则
 begin 
 Code.Jump：= $ E9; 
 Code.Offset：= PAnsiChar（Dest） -  PAnsiChar（Proc） -  SizeOf（Code）; 
 WriteProcessMemory（GetCurrentProcess，Proc，@Code，SizeOf（Code），n）; 
结束
结束
 
程序UnhookProc（Proc：Pointer; var BackupCode：TXRedirCode）; 
 var 
 n：NativeUInt; 
 begin 
 if（BackupCode.Jump<>> 0）和（Proc<> nil）then 
 begin 
 Proc：= GetActualAddr（Proc）; 
 Assert（Proc<> nil）; 
 WriteProcessMemory（GetCurrentProcess，Proc，@BackupCode，SizeOf（BackupCode），n）; 
 BackupCode.Jump：= 0; 
结束
结束
 
 
程序PaintPatch（Self：TObject）; 
 const 
 ButtonStyles：TThemedWindow =（twMDIMinButtonNormal，twMDIRestoreButtonNormal，twMDICloseButtonNormal）的数组[TMDIButtonStyle]; 
 var 
 LButton：TCustomMDIMenuButtonClass; 
 LDetails：TThemedElementDetails; 
 begin 
 LButton：= TCustomMDIMenuButtonClass（Self）; 
 LDetails：= StyleServices.GetElementDetails（ButtonStyles [LButton.ButtonStyle]）; 
 StyleServices.DrawElement（LButton.Canvas.Handle，LDetails，LButton.ClientRect）; 
结束
 
程序HookPaint; 
 begin 
 HookProc（@ TCustomMDIMenuButtonClass.Paint，@PaintPatch，PaintMethodBackup）; 
结束
 
程序UnHookPaint; 
 begin 
 UnhookProc（@ TCustomMDIMenuButtonClass.Paint，PaintMethodBackup）; 
结束
 
 
初始化
 HookPaint; 
 finalization 
 UnHookPaint; 
结束。 
  

结果将是

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

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

解决方案

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

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

这篇关于TActionMainMenuBar，VCL样式和MDI按钮（最小化，关闭等）不被设置。的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！