delphi - 在边缘上方/附近拖动时滚动 TTreeView

Question

我有一个 TTreeView，它可以有很多节点，当展开很多节点时，树会使用大量屏幕空间。

现在假设我想将 TreeView 底部附近的节点拖到顶部，但我实际上看不到 TreeView 的顶部部分，因为我选择的节点位于底部。当将节点拖动到 TreeView 的顶部时，我希望 TreeView 在拖动时自动与我一起滚动，默认情况下这似乎不会发生。

Windows 资源管理器中可以看到这种行为的完美示例。如果您尝试拖动文件或文件夹，当您将鼠标悬停在拖动的项目(节点)上时，它会根据光标位置自动向上或向下滚动。

希望这是有道理的。

PS，我已经知道如何拖动节点，如果将鼠标悬停在 TreeView 的顶部或底部附近，我希望在拖动时 TreeView 能够与我一起滚动。

谢谢。

Answer 1

这是我使用的代码。它适用于任何 TWinControl 后代:列表框、 TreeView 、 ListView 等。

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;