How can I set the background color for a StringTree with VCL Styles?

Question

I am trying to change the color of a Virtual StringTree for VCL Styles. This effects the part of the tree that is outside (right and bottom) of the cells when the columns and rows do not fill the whole component area.

For Styles this color is represented by scTreeView and will be applied through

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;

Unfortunately changing a styles scTreeView leads to changing the background color of all TreeViews in my app (not only Virtual StringTrees).

But I only want to change the color of the StringTrees.

Without Styles you can set the Color property for each StringTree individually. I am not sure if the implemented scTreeView for VCL Styles is wrong behavior and should be fixed. But it is different behavior from the unstyled StringTree.

Question: How can I fix this background color for my StringTrees? (all, not necessarily individually)

Shall I create a StyleHook? Which methods do I need to implement? Is it possible to override or interpose a specific class?

Since the `BackgroundColor` color is used for many parts of the tree (including e.g. drag image), I'm afraid you will need to modify that getter. Making a custom hook won't help here since the color is obtained for the style services `scTreeView` part, and virtual tree doesn't use style hooks for painting (except for scrollbars). — TLama, Aug 01 '14 at 12:32
You mean it will only be possible by altering the VirtualTrees source code or is there a chance to for example derive some class? I could create my own string tree but I am not sure if deriving TVTColors leads to anything. — Erik Virtel, Aug 01 '14 at 12:53
That getter is a private method whose code you need to alter. That is possible with a few hacks, but I've offered modifying VT source code since that is the easiest way. — TLama, Aug 01 '14 at 13:23

score 3 · Accepted Answer · answered Aug 01 '14 at 16:11

As @TLama suggest the easy way to do this is modifying the source code of the VirtualTrees unit to something like

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;

Now if you don't want modify the source code, you can patch that function using a detour and a class helper to get access to the private members.

Try the next code

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.

How can I set the background color for a StringTree with VCL Styles?

1 Answers1