delphi - 如何使用 VCL 样式设置 StringTree 的背景颜色？

Question

我正在尝试更改 VCL 样式的虚拟 StringTree 的颜色。当列和行未填充整个组件区域时，这会影响单元格外部(右侧和底部)的树部分。

对于样式，此颜色由 scTreeView 表示，并将通过

应用

function TVTColors.GetBackgroundColor: TColor;
begin
// XE2 VCL Style
{$IF CompilerVersion >= 23 }
  if FOwner.VclStyleEnabled then
    Result := StyleServices.GetStyleColor(scTreeView)
  else
{$IFEND}
    Result := FOwner.Color;
end;

不幸的是，更改样式 scTreeView 会导致更改我的应用中所有 TreeView 的背景颜色(不仅是虚拟 StringTree)。

但我只想更改 StringTrees 的颜色。

如果没有样式，您可以单独设置每个 StringTree 的 Color 属性。我不确定为 VCL 样式实现的 scTreeView 是否是错误的行为，是否应该修复。但它与无样式的 StringTree 的行为不同。

问题:如何修复 StringTree 的背景颜色？ (全部，不一定是单独的)

我应该创建一个 StyleHook 吗？我需要实现哪些方法？是否可以覆盖或插入特定的类？

Answer 1

正如 @TLama 所建议的，最简单的方法是将 VirtualTrees 单元的源代码修改为类似的内容

function TVTColors.GetBackgroundColor: TColor;
begin
// XE2 VCL Style
{$IF CompilerVersion >= 23 }
  if FOwner.VclStyleEnabled and not (Self.Owner is TVirtualStringTree) then
    Result := StyleServices.GetStyleColor(scTreeView)
  else
{$IFEND}
    Result := FOwner.Color;
end;

现在，如果您不想修改源代码，您可以使用绕行和类助手来修补该函数，以访问私有(private)成员。

尝试下一个代码

unit VirtualTreesHooks;

interface

implementation

Uses
  Winapi.Windows,
  System.SysUtils,
  Vcl.Themes,
  Vcl.Graphics,
  VirtualTrees;

type
  TJumpOfs = Integer;
  PPointer = ^Pointer;

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

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

  TVTColorsHelper  = class helper for TVTColors
  private
    function GetOwner: TBaseVirtualTree;
  public
    function GetBackgroundColorAddress : Pointer;
    property Owner: TBaseVirtualTree read GetOwner;
  end;


var
 GetBackgroundColorBackup: TXRedirCode; //Store the original address of the function to patch

type
  TBaseVirtualTreeClass= class(TBaseVirtualTree);

//this is the implementation of the new function   GetBackgroundColor
function GetBackgroundColorHook(Self : TVTColors): TColor;
begin
  if TBaseVirtualTreeClass(Self.Owner).VclStyleEnabled and not (Self.Owner is TVirtualStringTree) then
    Result := StyleServices.GetStyleColor(scTreeView)
  else
    Result := TBaseVirtualTreeClass(Self.Owner).Color;
end;

//get the address of a procedure or method of a function
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;

//patch the original function or procedure
procedure HookProc(Proc, Dest: Pointer; var BackupCode: TXRedirCode);
var
  n: {$IFDEF VER230}NativeUInt{$ELSE}DWORD{$ENDIF};
  Code: TXRedirCode;
begin
  Proc := GetActualAddr(Proc);
  Assert(Proc <> nil);
  //store the address of the original procedure to patch
  if ReadProcessMemory(GetCurrentProcess, Proc, @BackupCode, SizeOf(BackupCode), n) then
  begin
    Code.Jump := $E9;
    Code.Offset := PAnsiChar(Dest) - PAnsiChar(Proc) - SizeOf(Code);
    //replace the target procedure address  with the new one.
    WriteProcessMemory(GetCurrentProcess, Proc, @Code, SizeOf(Code), n);
  end;
end;

//restore the original address of the hooked function or procedure
procedure UnhookProc(Proc: Pointer; var BackupCode: TXRedirCode);
var
  n: {$IFDEF VER230}NativeUInt{$ELSE}Cardinal{$ENDIF};
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;

//get the address of the private method GetBackgroundColor
function TVTColorsHelper.GetBackgroundColorAddress : Pointer;
var
  MethodAddr: function : TColor of object;
begin
  MethodAddr := Self.GetBackgroundColor;
  Result     := TMethod(MethodAddr).Code;
end;

function TVTColorsHelper.GetOwner: TBaseVirtualTree;
begin
  Result:= Self.FOwner;
end;

initialization
  HookProc(TVTColors(nil).GetBackgroundColorAddress, @GetBackgroundColorHook, GetBackgroundColorBackup);
finalization
  UnhookProc(TVTColors(nil).GetBackgroundColorAddress, GetBackgroundColorBackup);
end.