How to create a slowing scroll effect on a scrollbox?
Solution 1:
The idea:
As per your comment, it should feel like Google Maps and thus while dragging the image, the image should stick to the mouse pointer; no special effects required so far. But at releasing the mouse button, the image needs to move (the scroll box needs to pan) further in the same direction and with a gradually easing speed, starting with the dragging velocity at the moment the mouse button was released.
So we need:
- a drag handler for when the mouse is pressed:
OnMouseMove
will work, - the panning speed at the moment the mouse is released: during the drag operation, we will track the latest speed with a timer,
- something that still moves the image after the mouse release: we use the same timer,
- a way to update the GUI: updating the image position, scrolling the scroll box and updating the scroll bar positions. Luckily, setting the position of the scroll bars of the scroll box will do all that,
- a function to gradually decrease the speed after mouse release. I chose for a simple linear factor, but you can experiment with that.
Setup:
- Drop a
TScrollBox
on your form, create event handlers forOnMouseDown
,OnMouseMove
andOnMouseUp
and set theDoubleBuffered
property toTrue
(this needs to be done runtime), - Drop a
TTimer
on your form, set its interval to 15 milliseconds (~ 67 Hz refresh rate) and create an event handler forOnTimer
, - Drop a
TImage
on the scroll box, load a picture, set the size to something big (e.g. 3200 x 3200), setStretch
toTrue
and setEnabled
toFalse
to let the mouse events through to the scroll box.
Code (for scroll box):
unit Unit1;
interface
uses
Windows, SysUtils, Classes, Controls, Forms, JPEG, ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
ScrollBox: TScrollBox;
Image: TImage;
TrackingTimer: TTimer;
procedure ScrollBoxMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ScrollBoxMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ScrollBoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure TrackingTimerTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
FDragging: Boolean;
FPrevScrollPos: TPoint;
FPrevTick: Cardinal;
FSpeedX: Single;
FSpeedY: Single;
FStartPos: TPoint;
function GetScrollPos: TPoint;
procedure SetScrollPos(const Value: TPoint);
public
property ScrollPos: TPoint read GetScrollPos write SetScrollPos;
end;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
ScrollBox.DoubleBuffered := True;
end;
function TForm1.GetScrollPos: TPoint;
begin
with ScrollBox do
Result := Point(HorzScrollBar.Position, VertScrollBar.Position);
end;
procedure TForm1.ScrollBoxMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := True;
FPrevTick := GetTickCount;
FPrevScrollPos := ScrollPos;
TrackingTimer.Enabled := True;
FStartPos := Point(ScrollPos.X + X, ScrollPos.Y + Y);
Screen.Cursor := crHandPoint;
end;
procedure TForm1.ScrollBoxMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
if FDragging then
ScrollPos := Point(FStartPos.X - X, FStartPos.Y - Y);
end;
procedure TForm1.ScrollBoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := False;
Screen.Cursor := crDefault;
end;
procedure TForm1.SetScrollPos(const Value: TPoint);
begin
ScrollBox.HorzScrollBar.Position := Value.X;
ScrollBox.VertScrollBar.Position := Value.Y;
end;
procedure TForm1.TrackingTimerTimer(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
TrackingTimer.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;
end.
Code (for panel):
And in case you do not want the scroll bars then use the following code. The example uses a panel as container, but that could be any windowed control or the form itself.
unit Unit2;
interface
uses
Windows, SysUtils, Classes, Controls, Forms, JPEG, ExtCtrls, Math;
type
TForm2 = class(TForm)
Panel: TPanel;
Image: TImage;
TrackingTimer: TTimer;
procedure PanelMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure PanelMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure PanelMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure TrackingTimerTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
FDragging: Boolean;
FPrevImagePos: TPoint;
FPrevTick: Cardinal;
FSpeedX: Single;
FSpeedY: Single;
FStartPos: TPoint;
function GetImagePos: TPoint;
procedure SetImagePos(Value: TPoint);
public
property ImagePos: TPoint read GetImagePos write SetImagePos;
end;
implementation
{$R *.dfm}
procedure TForm2.FormCreate(Sender: TObject);
begin
Panel.DoubleBuffered := True;
end;
function TForm2.GetImagePos: TPoint;
begin
Result.X := Image.Left;
Result.Y := Image.Top;
end;
procedure TForm2.PanelMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := True;
FPrevTick := GetTickCount;
FPrevImagePos := ImagePos;
TrackingTimer.Enabled := True;
FStartPos := Point(X - Image.Left, Y - Image.Top);
Screen.Cursor := crHandPoint;
end;
procedure TForm2.PanelMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FDragging then
ImagePos := Point(X - FStartPos.X, Y - FStartPos.Y);
end;
procedure TForm2.PanelMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := False;
Screen.Cursor := crDefault;
end;
procedure TForm2.SetImagePos(Value: TPoint);
begin
Value.X := Max(Panel.ClientWidth - Image.Width, Min(0, Value.X));
Value.Y := Max(Panel.ClientHeight - Image.Height, Min(0, Value.Y));
Image.SetBounds(Value.X, Value.Y, Image.Width, Image.Height);
end;
procedure TForm2.TrackingTimerTimer(Sender: TObject);
var
Delay: Cardinal;
begin
Delay := GetTickCount - FPrevTick;
if FDragging then
begin
if Delay = 0 then
Delay := 1;
FSpeedX := (ImagePos.X - FPrevImagePos.X) / Delay;
FSpeedY := (ImagePos.Y - FPrevImagePos.Y) / Delay;
end
else
begin
if (Abs(FSpeedX) < 0.005) and (Abs(FSpeedY) < 0.005) then
TrackingTimer.Enabled := False
else
begin
ImagePos := Point(FPrevImagePos.X + Round(Delay * FSpeedX),
FPrevImagePos.Y + Round(Delay * FSpeedY));
FSpeedX := 0.83 * FSpeedX;
FSpeedY := 0.83 * FSpeedY;
end;
end;
FPrevImagePos := ImagePos;
FPrevTick := GetTickCount;
end;
end.
Code (for paint box):
And when the image's dimensions are limitless (e.g. a globe), you can use a paint box to glue the image's ends together.
unit Unit3;
interface
uses
Windows, SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls, JPEG;
type
TForm3 = class(TForm)
Painter: TPaintBox;
Tracker: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure PainterMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure PainterMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure PainterMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure PainterPaint(Sender: TObject);
procedure TrackerTimer(Sender: TObject);
private
FDragging: Boolean;
FGraphic: TGraphic;
FOffset: Integer;
FPrevOffset: Integer;
FPrevTick: Cardinal;
FSpeed: Single;
FStart: Integer;
procedure SetOffset(Value: Integer);
public
property Offset: Integer read FOffset write SetOffset;
end;
implementation
{$R *.dfm}
procedure TForm3.FormCreate(Sender: TObject);
begin
DoubleBuffered := True;
FGraphic := TJPEGImage.Create;
FGraphic.LoadFromFile('gda_world_map_small.jpg');
Constraints.MaxWidth := FGraphic.Width + 30;
end;
procedure TForm3.FormDestroy(Sender: TObject);
begin
FGraphic.Free;
end;
procedure TForm3.PainterMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := True;
FPrevTick := GetTickCount;
FPrevOffset := Offset;
Tracker.Enabled := True;
FStart := X - FOffset;
Screen.Cursor := crHandPoint;
end;
procedure TForm3.PainterMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FDragging then
Offset := X - FStart;
end;
procedure TForm3.PainterMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDragging := False;
Screen.Cursor := crDefault;
end;
procedure TForm3.PainterPaint(Sender: TObject);
begin
Painter.Canvas.Draw(FOffset, 0, FGraphic);
Painter.Canvas.Draw(FOffset + FGraphic.Width, 0, FGraphic);
end;
procedure TForm3.SetOffset(Value: Integer);
begin
FOffset := Value;
if FOffset < -FGraphic.Width then
begin
Inc(FOffset, FGraphic.Width);
Dec(FStart, FGraphic.Width);
end
else if FOffset > 0 then
begin
Dec(FOffset, FGraphic.Width);
Inc(FStart, FGraphic.Width);
end;
Painter.Invalidate;
end;
procedure TForm3.TrackerTimer(Sender: TObject);
var
Delay: Cardinal;
begin
Delay := GetTickCount - FPrevTick;
if FDragging then
begin
if Delay = 0 then
Delay := 1;
FSpeed := (Offset - FPrevOffset) / Delay;
end
else
begin
if Abs(FSpeed) < 0.005 then
Tracker.Enabled := False
else
begin
Offset := FPrevOffset + Round(Delay * FSpeed);
FSpeed := 0.83 * FSpeed;
end;
end;
FPrevOffset := Offset;
FPrevTick := GetTickCount;
end;
end.