gpt4 book ai didi

delphi - TActionMainMenuBar、VCL 样式和 MDI 按钮(最小化、关闭等)未设置样式。

转载 作者:行者123 更新时间:2023-12-03 14:51:47 26 4
gpt4 key购买 nike

我正在尝试使 TActionMainMenuBar 像 TMainMenu 一样显示样式化的 MDI 按钮。

VCL Styles problem

有什么建议吗?我无法停止在这个项目中使用 MDI。

最佳答案

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

enter image description here

enter image description here

问题位于使用旧的 DrawFrameControlTCustomMDIMenuButton.Paint 方法中。 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, 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.

结果将是

enter image description here enter image description here

关于delphi - TActionMainMenuBar、VCL 样式和 MDI 按钮(最小化、关闭等)未设置样式。,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/16876977/

26 4 0
Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
广告合作:1813099741@qq.com 6ren.com