How to synchronize the scrolling of 2 TTreeviews?

Question

I have 2 TTreeviews. Both of them have the same number of items. I'd like to be able to synchronize their scrollbars... If I move one of them, the other moves also...

For the horizontal, it works as I expect... For the vertical, it works if I use the arrows of the scrollbar, but it doesn't if I drag the thumb or if I use the mouse wheel...

Here is a sample I've written to illustrate my issue:

unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, StrUtils;

type
  TForm1 = class(TForm)
    tv1: TTreeView;
    tv2: TTreeView;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    originalTv1WindowProc : TWndMethod;
    originalTv2WindowProc : TWndMethod;
    procedure Tv1WindowProc (var Msg : TMessage);
    procedure Tv2WindowProc (var Msg : TMessage);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to 10 do
  begin
    tv1.Items.AddChild(nil, DupeString('A', 20) + IntToStr(i));
    tv2.Items.AddChild(nil, DupeString('B', 20) + IntToStr(i));
  end;

  originalTv1WindowProc := tv1.WindowProc;
  tv1.WindowProc        := Tv1WindowProc;
  originalTv2WindowProc := tv2.WindowProc;
  tv2.WindowProc        := Tv2WindowProc;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  tv1.WindowProc := originalTv1WindowProc;
  tv2.WindowProc := originalTv2WindowProc;

  originalTv1WindowProc := nil;
  originalTv2WindowProc := nil;
end;

procedure TForm1.Tv1WindowProc(var Msg: TMessage);
begin
  originalTv1WindowProc(Msg);
  if ((Msg.Msg = WM_VSCROLL)
   or (Msg.Msg = WM_HSCROLL)
   or (Msg.msg = WM_Mousewheel)) then
  begin
//    tv2.Perform(Msg.Msg, Msg.wparam, Msg.lparam);
    originalTv2WindowProc(Msg);
  end;
end;

procedure TForm1.Tv2WindowProc(var Msg: TMessage);
begin
  originalTv2WindowProc(Msg);
  if ((Msg.Msg = WM_VSCROLL)
   or (Msg.Msg = WM_HSCROLL)
   or (Msg.msg = WM_Mousewheel)) then
  begin
//    tv1.Perform(Msg.Msg, Msg.wparam, Msg.lparam);
    originalTv1WindowProc(Msg);
  end;
end;

end.

The DFM:

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 113
  ClientWidth = 274
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object tv1: TTreeView
    Left = 8
    Top = 8
    Width = 121
    Height = 97
    Indent = 19
    TabOrder = 0
  end
  object tv2: TTreeView
    Left = 144
    Top = 8
    Width = 121
    Height = 97
    Indent = 19
    TabOrder = 1
  end
end

I also tried creating a subclass from TTreeview, but without success (same behavior)... I tried with a TMemo, and it works as expected...

What did I miss?

Cheers,

W.

Answer 1

First, an interesting test: uncheck "enable runtime themes" in the project options and you'll see both of the treeviews will scroll synchronously. This shows us that the default window procedure for a treeview control is implemented differently in different versions of comctl32.dll. It would seem, the implementation in comctl32 v6 is particularly different when scrolling vertical.

Anyway, it appears that, for vertical scrolling only, the control looks for the thumb position and then adjusts the window contents accordingly. When you route a WM_VSCROLL to the adjacent treeview, it looks its thumb's position and as it is not changed, decides there's nothing to do (we only changed the thumb position of the one we are dragging).

So, to make it work, adjust the treeview's thumb position before sending the WM_VSCROLL. The modified procedure for tv1 would look like this:

procedure TForm1.Tv1WindowProc(var Msg: TMessage);
begin
  originalTv1WindowProc(Msg);

  if Msg.Msg = WM_VSCROLL then begin
    if Msg.WParamLo = SB_THUMBTRACK then
      SetScrollPos(tv2.Handle, SB_VERT, Msg.WParamHi, False);
  end;

  if ((Msg.Msg = WM_VSCROLL)
   or (Msg.Msg = WM_HSCROLL)
   or (Msg.msg = WM_Mousewheel)) then
  begin
//    tv2.Perform(Msg.Msg, Msg.wparam, Msg.lparam);
    originalTv2WindowProc(Msg);
  end;
end;

Answer 2

Updated:

Another answer I got on a French forum, from ShaiLeTroll:

This solution works perfectly.. I's always synchronized: arrows, thumb, horizontal, vertical, mouse wheel!

Here is the updated code (which mix both solutions: for thumb & for mouse wheel):

unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, StrUtils;

type
  TForm1 = class(TForm)
    tv1: TTreeView;
    tv2: TTreeView;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    originalTv1WindowProc : TWndMethod;
    originalTv2WindowProc : TWndMethod;

    sender: TTreeView;

    procedure Tv1WindowProc (var Msg : TMessage);
    procedure Tv2WindowProc (var Msg : TMessage);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
  tn: TTreeNode;
begin
  for i := 0 to 20 do
  begin
    tn := tv1.Items.AddChild(nil, DupeString('A', 20) + IntToStr(i));
    tv1.Items.AddChild(tn, DupeString('C', 20) + IntToStr(i));
    tv1.Items.AddChild(tn, DupeString('C', 20) + IntToStr(i));
    tn := tv2.Items.AddChild(nil, DupeString('B', 20) + IntToStr(i));
    tv2.Items.AddChild(tn, DupeString('D', 20) + IntToStr(i));
    tv2.Items.AddChild(tn, DupeString('D', 20) + IntToStr(i));
  end;

  originalTv1WindowProc := tv1.WindowProc;
  tv1.WindowProc        := Tv1WindowProc;
  originalTv2WindowProc := tv2.WindowProc;
  tv2.WindowProc        := Tv2WindowProc;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  tv1.WindowProc        := originalTv1WindowProc;
  tv2.WindowProc        := originalTv2WindowProc;
  originalTv1WindowProc := nil;
  originalTv2WindowProc := nil;
end;

procedure TForm1.Tv1WindowProc(var Msg: TMessage);
begin
  originalTv1WindowProc(Msg);

  if Msg.Msg = WM_VSCROLL then
  begin
    if Msg.WParamLo = SB_THUMBTRACK then
    begin
      SetScrollPos(tv2.Handle, SB_VERT, Msg.WParamHi, False);
    end;
  end;

  if (sender <> tv2) and
    ((Msg.Msg = WM_VSCROLL) or (Msg.Msg = WM_HSCROLL) or (Msg.Msg = WM_MOUSEWHEEL)) then
  begin
    sender := tv1;
    tv2.Perform(Msg.Msg, Msg.wparam, Msg.lparam);
    sender := nil;
  end;
end;

procedure TForm1.Tv2WindowProc(var Msg: TMessage);
begin
  originalTv2WindowProc(Msg);

  if Msg.Msg = WM_VSCROLL then
  begin
    if Msg.WParamLo = SB_THUMBTRACK then
    begin
      SetScrollPos(tv1.Handle, SB_VERT, Msg.WParamHi, False);
    end;
  end;

  if (sender <> tv1) and ((Msg.Msg = WM_VSCROLL) or (Msg.Msg = WM_HSCROLL) or (Msg.Msg = WM_MOUSEWHEEL)) then
  begin
    sender := tv2;
    tv1.Perform(Msg.Msg, Msg.wparam, Msg.lparam);
    sender := nil;
  end;
end;

end.