Question

我正在尝试为VCL样式更改Virtual 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的背景颜色（不仅仅是Virtual StringTrees）。

但我只想改变StringTrees的颜色。

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

问题：如何为StringTrees修复此背景颜色？（所有，不一定是单独的）

我要创建一个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;

现在，如果您不想修改源代码，可以使用绕道和类助手来修补该功能，以便访问私有成员。

尝试下一个代码

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.

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

1 个答案: