Przyciski TActionMainMenuBar, VCL-Style i MDI (Minimize, Close itp.) Nie są stylizowane.

Question

Próbuję uczynić wyświetlane przyciski MDI w stylu TActionMainMenuBar tak, jak robi to polecenie TMainMenu.

Wszelkie sugestie? Nie mogę przestać używać MDI dla tego projektu.

Answer 1

Ok, pierwszy to nie jest błąd Vcl Styles, jest to błąd VCL. Ten problem pojawia się nawet wtedy, gdy style Vcl są wyłączone.

Kwestia znajduje się w metodzie TCustomMDIMenuButton.Paint który używa starej metody DrawFrameControl WINAPI wyciągnąć przyciski z napisami.

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

Jako obejście można załatać tę metodę przy użyciu objazd a następnie wdrożenie nowej metody malowania przy użyciu StylesServices.

Po prostu dodaj to urządzenie do swojego projektu.

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. 

Rezultatem będzie