delphi – TScrollbox MouseDown覆盖

实际上并不是一个坏问题.由于大多数默认控件交互都与鼠标按钮的释放紧密相关(例如,OnClick在WM_LBUTTONUP中处理),这仍然应该以直观的方式实现.

我尝试了下面的代码,确实感觉非常好.它涉及：

>处理WM_PARENTNOTIFY以在单击子控件时捕获,
>绕过Child.OnMouseMove和Child.OnMouseUp,
>当移动超过Mouse.DragThreshold时,将控制权转移到滚动框,
>在拖动之前将焦点重置为先前的焦点控制,
>取消拖动后对子项鼠标事件所做的所有更改.

?

unit Unit2;

interface

uses
  Windows,Messages,Classes,Controls,Forms,StdCtrls,ExtCtrls;

type
  TScrollBox = class(Forms.TScrollBox)
  private
    FChild: TControl;
    FDragging: Boolean;
    FPrevActiveControl: TWinControl;
    FPrevScrollPos: TPoint;
    FPrevTick: Cardinal;
    FOldChildOnMouseMove: TMouseMoveEvent;
    FOldChildOnMouseUp: TMouseEvent;
    FSpeedX: Single;
    FSpeedY: Single;
    FStartPos: TPoint;
    FTracker: TTimer;
    function ActiveControl: TWinControl;
    procedure ChildMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
    procedure ChildMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X,Y: Integer);
    function GetScrollPos: TPoint;
    procedure SetScrollPos(const Value: TPoint);
    procedure Track(Sender: TObject);
    procedure WMParentNotify(var Message: TWMParentNotify);
      message WM_PARENTNOTIFY;
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X,Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X,Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
    property ScrollPos: TPoint read GetScrollPos write SetScrollPos;
  end;

  TForm2 = class(TForm)
    ScrollBox1: TScrollBox;
    ...
  end;

implementation

{$R *.dfm}

{ TScrollBox }

type
  TControlAccess = class(TControl);

function TScrollBox.ActiveControl: TWinControl;
var
  Control: TWinControl;
begin
  Result := Screen.ActiveControl;
  Control := Result;
  while (Control <> nil) do
  begin
    if Control = Self then
      Exit;
    Control := Control.Parent;
  end;
  Result := nil;
end;

procedure TScrollBox.ChildMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
begin
  if (Abs(FChild.Left + X - FStartPos.X) > Mouse.DragThreshold) or
    (Abs(FChild.Top + Y - FStartPos.Y) > Mouse.DragThreshold) then
  begin
    MouseCapture := True;
    TControlAccess(FChild).OnMouseMove := FOldChildOnMouseMove;
    TControlAccess(FChild).OnMouseUp := FOldChildOnMouseUp;
    MouseDown(mbLeft,Shift,FChild.Left + X,FChild.Top + Y);
    FChild := nil;
    if FPrevActiveControl <> nil then
      FPrevActiveControl.SetFocus;
  end
  else
    if Assigned(FOldChildOnMouseMove) then
      FOldChildOnMouseMove(Sender,X,Y);
end;

procedure TScrollBox.ChildMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X,Y: Integer);
begin
  if FChild <> nil then
  begin
    if Assigned(FOldChildOnMouseUp) then
      FOldChildOnMouseUp(Sender,Button,Y);
    TControlAccess(FChild).OnMouseMove := FOldChildOnMouseMove;
    TControlAccess(FChild).OnMouseUp := FOldChildOnMouseUp;
    FChild := nil;
  end;
end;

constructor TScrollBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FTracker := TTimer.Create(Self);
  FTracker.Enabled := False;
  FTracker.Interval := 15;
  FTracker.OnTimer := Track;
end;

function TScrollBox.GetScrollPos: TPoint;
begin
  Result := Point(HorzScrollBar.Position,VertScrollBar.Position);
end;

procedure TScrollBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X,Y: Integer);
begin
  FDragging := True;
  FPrevTick := GetTickCount;
  FPrevScrollPos := ScrollPos;
  FTracker.Enabled := True;
  FStartPos := Point(ScrollPos.X + X,ScrollPos.Y + Y);
  Screen.Cursor := crHandPoint;
  inherited MouseDown(Button,Y);
end;

procedure TScrollBox.MouseMove(Shift: TShiftState; X,Y: Integer);
begin
  if FDragging then
    ScrollPos := Point(FStartPos.X - X,FStartPos.Y - Y);
  inherited MouseMove(Shift,Y);
end;

procedure TScrollBox.MouseUp(Button: TMouseButton; Shift: TShiftState; X,Y: Integer);
begin
  FDragging := False;
  Screen.Cursor := crDefault;
  inherited MouseUp(Button,Y);
end;

procedure TScrollBox.SetScrollPos(const Value: TPoint);
begin
  HorzScrollBar.Position := Value.X;
  VertScrollBar.Position := Value.Y;
end;

procedure TScrollBox.Track(Sender: TObject);
var
  Delay: Cardinal;
begin
  Delay := GetTickCount - FPrevTick;
  if FDragging then
  begin
    if Delay = 0 then
      Delay := 1;
    FSpeedX := (ScrollPos.X - FPrevScrollPos.X) / Delay;
    FSpeedY := (ScrollPos.Y - FPrevScrollPos.Y) / Delay;
  end
  else
  begin
    if (Abs(FSpeedX) < 0.005) and (Abs(FSpeedY) < 0.005) then
      FTracker.Enabled := False
    else
    begin
      ScrollPos := Point(FPrevScrollPos.X + Round(Delay * FSpeedX),FPrevScrollPos.Y + Round(Delay * FSpeedY));
      FSpeedX := 0.83 * FSpeedX;
      FSpeedY := 0.83 * FSpeedY;
    end;
  end;
  FPrevScrollPos := ScrollPos;
  FPrevTick := GetTickCount;
end;

procedure TScrollBox.WMParentNotify(var Message: TWMParentNotify);
begin
  inherited;
  if Message.Event = WM_LBUTTONDOWN then
  begin
    FChild := ControlAtPos(Point(Message.XPos,Message.YPos),False,True);
    if FChild <> nil then
    begin
      FPrevActiveControl := ActiveControl;
      FOldChildOnMouseMove := TControlAccess(FChild).OnMouseMove;
      TControlAccess(FChild).OnMouseMove := ChildMouseMove;
      FOldChildOnMouseUp := TControlAccess(FChild).OnMouseUp;
      TControlAccess(FChild).OnMouseUp := ChildMouseUp;
    end;
  end;
end;

end.

注意：如果未启动拖动(鼠标移动< Mouse.DragThreshold),则单击的子项的所有鼠标和单击事件将保持不变.否则只有Child.OnMouseDown会开火！ 出于测试目的,this answer包含在上面的代码中.

感谢@TLama建议使用WM_PARENTNOTIFY.