Создание кастомного скроллбокса в Delphi с перетаскиванием мыши для прокрутки

Delphi , Компоненты и Классы , TScrollBox

При разработке приложений на Delphi часто возникает необходимость в создании кастомных компонентов, обладающих расширенным функционалом по сравнению со стандартными. Одним из таких компонентов может быть кастомный скроллбокс, который позволяет прокручивать содержимое при перетаскивании мыши в клиентской области, а не только с помощью полос прокрутки.

В данной статье мы рассмотрим, как создать такой кастомный скроллбокс и решить проблему, при которой перетаскивание мыши не работает, если курсор находится над кнопкой или панелью внутри скроллбокса.

Решение проблемы

Для решения данной проблемы можно использовать перехват сообщения WM_PARENTNOTIFY, которое отправляется родительскому окну, когда одно из его дочерних окон получает сообщение. В нашем случае это позволит нам перехватить событие нажатия левой кнопки мыши на дочернем контроле и игнорировать стандартное поведение, если началось перетаскивание мыши.

Ниже приведен пример кода на Object Pascal (Delphi), который демонстрирует реализацию кастомного скроллбокса с перетаскиванием мыши для прокрутки:

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, 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, Shift, 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, Shift, X, 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, Shift, X, 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, X, Y);
end;

procedure TScrollBox.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  FDragging := False;
  Screen.Cursor := crDefault;
  inherited MouseUp(Button, Shift, X, 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.

В данном примере мы создаем кастомный скроллбокс, унаследованный от стандартного TScrollBox. В методе WMParentNotify мы перехватываем сообщение WM_LBUTTONDOWN и получаем дочерний контроль, на котором произошло нажатие левой кнопки мыши. Если курсор находится над кнопкой или панелью, мы перехватываем события OnMouseMove и OnMouseUp этого контрола и обрабатываем их в методах ChildMouseMove и ChildMouseUp соответственно.

При перетаскивании мыши более чем на величину Mouse.DragThreshold мы захватываем мышь и начинаем обрабатывать события прокрутки в методе MouseMove. Если перетаскивание прекращается, мы восстанавливаем стандартное поведение дочернего контрола, на котором произошло нажатие левой кнопки мыши.

Таким образом, мы создаем кастомный скроллбокс, который позволяет прокручивать содержимое при перетаскивании мыши в клиентской области, а также решаем проблему, при которой перетаскивание мыши не работает, если курсор находится над кнопкой или панелью внутри скроллбокса.

Создано по материалам из источника по ссылке.

При разработке приложений на Delphi часто бывает необходимо создать кастомный скроллбокс, который позволяет прокручивать содержимое при перетаскивании мыши в клиентской области, а не только с помощью полос прокрутки. В данной статье рассматривается, как с

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: TScrollBox ::