Scroll TTreeView while dragging over/near the edges

Question

I have a TTreeView that can have lots of nodes, when a lot of nodes are expanded the tree uses a lot of screen space.

Now suppose I want to drag a node that is near

Answer 1

Here's an alternative based on the fact that the selected node always automatically scrolls in view.

type
  TForm1 = class(TForm)
    TreeView1: TTreeView;
    TreeView2: TTreeView;
    procedure TreeViewDragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure TreeViewEndDrag(Sender, Target: TObject; X, Y: Integer);
    procedure TreeViewMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    FDragNode: TTreeNode;
    FNodeHeight: Integer;
  end;

...

procedure TForm1.TreeViewMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  with TTreeView(Sender) do
  begin
    FDragNode := GetNodeAt(X, Y);
    if FDragNode <> nil then
    begin
      Selected := FDragNode;
      with FDragNode.DisplayRect(False) do
        FNodeHeight := Bottom - Top;
      BeginDrag(False, Mouse.DragThreshold);
    end;
  end;
end;

procedure TForm1.TreeViewDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
var
  Pt: TPoint;
  DropNode: TTreeNode;
begin
  Accept := Source is TTreeView;
  if Accept then
    with TTreeView(Source) do
    begin
      if Sender <> Source then
        Pt := ScreenToClient(Mouse.CursorPos)
      else
        Pt := Point(X, Y);
      if Pt.Y < FNodeHeight then
        DropNode := Selected.GetPrevVisible
      else if Pt.Y > (ClientHeight - FNodeHeight) then
        DropNode := Selected.GetNextVisible
      else
        DropNode := GetNodeAt(Pt.X, Pt.Y);
      if DropNode <> nil then
        Selected := DropNode;
    end;
end;

procedure TForm1.TreeViewEndDrag(Sender, Target: TObject; X, Y: Integer);
var
  DropNode: TTreeNode;
begin
  with TTreeView(Sender) do
    if Target <> nil then
    begin
      DropNode := Selected;
      DropNode := Items.Insert(DropNode, '');
      DropNode.Assign(FDragNode);
      Selected := DropNode;
      Items.Delete(FDragNode);
    end
    else
      Selected := FDragNode;
end;

You may want to link the OnDragOver event handler to the parent of the TreeView too, which results in scrolling ánd dropping when the mouse is outside the TreeView. If you dó want the scrolling, but not the dropping when the mouse is outside the TreeView, then check if Target = Sender in the OnEndDrag event handler.

Answer 2

This is the code I use. It will work for any TWinControl descendent: list box, tree view, list view etc.

type
  TAutoScrollTimer = class(TTimer)
  private
    FControl: TWinControl;
    FScrollCount: Integer;
    procedure InitialiseTimer;
    procedure Timer(Sender: TObject);
  public
    constructor Create(Control: TWinControl);
  end;

{ TAutoScrollTimer }

constructor TAutoScrollTimer.Create(Control: TWinControl);
begin
  inherited Create(Control);
  FControl := Control;
  InitialiseTimer;
end;

procedure TAutoScrollTimer.InitialiseTimer;
begin
  FScrollCount := 0;
  Interval := 250;
  Enabled := True;
  OnTimer := Timer;
end;

procedure TAutoScrollTimer.Timer(Sender: TObject);

  procedure DoScroll;
  var
    WindowEdgeTolerance: Integer;
    Pos: TPoint;
  begin
    WindowEdgeTolerance := Min(25, FControl.Height div 4);
    GetCursorPos(Pos);
    Pos := FControl.ScreenToClient(Pos);
    if not InRange(Pos.X, 0, FControl.Width) then begin
      exit;
    end;
    if Pos.Y<WindowEdgeTolerance then begin
      SendMessage(FControl.Handle, WM_VSCROLL, SB_LINEUP, 0);
    end else if Pos.Y>FControl.Height-WindowEdgeTolerance then begin
      SendMessage(FControl.Handle, WM_VSCROLL, SB_LINEDOWN, 0);
    end else begin
      InitialiseTimer;
      exit;
    end;

    if FScrollCount<50 then begin
      inc(FScrollCount);
      if FScrollCount mod 5=0 then begin
        //speed up the scrolling by reducing the timer interval
        Interval := MulDiv(Interval, 3, 4);
      end;
    end;

    if Win32MajorVersion<6 then begin
      //in XP we need to clear up transient "fluff"; results in flickering so only do it in XP where it is needed
      FControl.Invalidate;
    end;
  end;

begin
  if Mouse.IsDragging then begin
    DoScroll;
  end else begin
    Free;
  end;
end;

Then to use it you add an OnStartDrag event handler for the control and implement it like this:

procedure TMyForm.SomeControlStartDrag(Sender: TObject; var DragObject: TDragObject);
begin
  TAutoScrollTimer.Create(Sender as TWinControl);
end;

Answer 3

Just to be complete, workarounds like in the other answers are not required anymore. Later versions have an option for this:

TreeOptions.AutoOptions.toAutoScroll := True