我有一个可以有很多节点的 TTreeView，当展开很多节点时，树会占用大量屏幕空间。
现在假设我想将一个靠近 TreeView 底部的节点拖到顶部，我无法实际看到 TreeView 的顶部，因为我选择的节点位于底部。将节点拖动到 TreeView 的顶部时，我希望 TreeView 在拖动时自动滚动，默认情况下这似乎不会发生。
在 Windows 资源管理器中可以看到这种行为的完美示例。如果您尝试拖动文件或文件夹，当您悬停拖动的项目（节点）时，它会根据光标位置自动向上或向下滚动。
希望这是有道理的。
PS，我已经知道如何拖动节点，如果悬停在 TreeView 的顶部或底部附近，我希望 TreeView 在拖动时与我一起滚动。
谢谢。
【问题讨论】：
这是我使用的代码。它适用于任何TWinControl 后代：列表框、树视图、列表视图等。
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;
然后要使用它，您需要为控件添加一个OnStartDrag 事件处理程序并像这样实现它：
procedure TMyForm.SomeControlStartDrag(Sender: TObject; var DragObject: TDragObject);
begin
TAutoScrollTimer.Create(Sender as TWinControl);
end;
【讨论】：
WindowEdgeTolerance := 25 而不是我的版本，没人会注意到。
这是基于所选节点始终在视图中自动滚动这一事实的替代方案。
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;
您可能也希望将 OnDragOver 事件处理程序链接到 TreeView 的父级，这会导致鼠标在 TreeView 之外时滚动和下降。如果您想要滚动，但不想在鼠标位于 TreeView 之外时放下，请在 OnEndDrag 事件处理程序中检查 if Target = Sender。
【讨论】：
为了完整起见，不再需要其他答案中的解决方法。更高版本有一个选项：
TreeOptions.AutoOptions.toAutoScroll := True
【讨论】：