mirror of
https://git.vladimir.cc/vladimir/ewsdr.git
synced 2026-08-25 20:37:33 +00:00
feat(ui): add hover overlay scroll for left panel
This commit is contained in:
@@ -0,0 +1,237 @@
|
||||
unit OverlayScrollBar;
|
||||
|
||||
{
|
||||
Тонкий вертикальный overlay-scrollbar без системного оформления.
|
||||
|
||||
Сам контрол всегда занимает зарезервированный gutter, но трек и бегунок
|
||||
рисуются только при Max > 0 и наведении мыши на HoverTarget. Содержимое
|
||||
контрол не двигает: владелец подписывается на OnPositionChange.
|
||||
}
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, Controls, ExtCtrls, Forms, Graphics, Math, Types, LCLType;
|
||||
|
||||
type
|
||||
TOverlayScrollBar = class(TPaintBox)
|
||||
private
|
||||
FHoverTarget: TControl;
|
||||
FMaximum: Integer;
|
||||
FPosition: Integer;
|
||||
FViewportSize: Integer;
|
||||
FHover: Boolean;
|
||||
FDragging: Boolean;
|
||||
FDragY: Integer;
|
||||
FDragPosition: Integer;
|
||||
FBGColor: TColor;
|
||||
FTrackColor: TColor;
|
||||
FThumbColor: TColor;
|
||||
FThumbDragColor: TColor;
|
||||
FOnPositionChange: TNotifyEvent;
|
||||
procedure AppUserInput(Sender: TObject; Msg: Cardinal);
|
||||
procedure SetPosition(AValue: Integer);
|
||||
function CursorOverTarget: Boolean;
|
||||
function ThumbRect: TRect;
|
||||
protected
|
||||
procedure Paint; override;
|
||||
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;
|
||||
destructor Destroy; override;
|
||||
procedure SetRange(AMaximum, AViewportSize: Integer);
|
||||
procedure ScrollBy(ADelta: Integer);
|
||||
procedure SetColors(ABG, ATrack, AThumb, AThumbDrag: TColor);
|
||||
property HoverTarget: TControl read FHoverTarget write FHoverTarget;
|
||||
property Maximum: Integer read FMaximum;
|
||||
property Position: Integer read FPosition write SetPosition;
|
||||
property OnPositionChange: TNotifyEvent
|
||||
read FOnPositionChange write FOnPositionChange;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TOverlayScrollBar.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
Width := 8;
|
||||
FMaximum := 0;
|
||||
FPosition := 0;
|
||||
FViewportSize := 0;
|
||||
FHover := False;
|
||||
FDragging := False;
|
||||
FBGColor := TColor($00181818);
|
||||
FTrackColor := TColor($00303030);
|
||||
FThumbColor := TColor($00407040);
|
||||
FThumbDragColor := TColor($00509050);
|
||||
Application.AddOnUserInputHandler(@AppUserInput);
|
||||
end;
|
||||
|
||||
destructor TOverlayScrollBar.Destroy;
|
||||
begin
|
||||
Application.RemoveOnUserInputHandler(@AppUserInput);
|
||||
if GetCaptureControl = Self then SetCaptureControl(nil);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TOverlayScrollBar.SetColors(ABG, ATrack, AThumb,
|
||||
AThumbDrag: TColor);
|
||||
begin
|
||||
FBGColor := ABG;
|
||||
FTrackColor := ATrack;
|
||||
FThumbColor := AThumb;
|
||||
FThumbDragColor := AThumbDrag;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TOverlayScrollBar.SetRange(AMaximum, AViewportSize: Integer);
|
||||
var
|
||||
OldMaximum: Integer;
|
||||
begin
|
||||
OldMaximum := FMaximum;
|
||||
FMaximum := Max(0, AMaximum);
|
||||
FViewportSize := Max(0, AViewportSize);
|
||||
if FPosition > FMaximum then
|
||||
SetPosition(FMaximum)
|
||||
else if OldMaximum <> FMaximum then
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TOverlayScrollBar.SetPosition(AValue: Integer);
|
||||
var
|
||||
NewValue: Integer;
|
||||
begin
|
||||
NewValue := EnsureRange(AValue, 0, FMaximum);
|
||||
if NewValue = FPosition then Exit;
|
||||
FPosition := NewValue;
|
||||
if Assigned(FOnPositionChange) then FOnPositionChange(Self);
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TOverlayScrollBar.ScrollBy(ADelta: Integer);
|
||||
begin
|
||||
SetPosition(FPosition + ADelta);
|
||||
end;
|
||||
|
||||
function TOverlayScrollBar.CursorOverTarget: Boolean;
|
||||
var
|
||||
P: TPoint;
|
||||
begin
|
||||
Result := False;
|
||||
if (FHoverTarget = nil) or (not FHoverTarget.Visible) then Exit;
|
||||
P := FHoverTarget.ScreenToClient(Mouse.CursorPos);
|
||||
Result := (P.X >= 0) and (P.Y >= 0) and
|
||||
(P.X < FHoverTarget.Width) and (P.Y < FHoverTarget.Height);
|
||||
end;
|
||||
|
||||
procedure TOverlayScrollBar.AppUserInput(Sender: TObject; Msg: Cardinal);
|
||||
var
|
||||
NewHover: Boolean;
|
||||
begin
|
||||
NewHover := CursorOverTarget;
|
||||
if NewHover = FHover then Exit;
|
||||
FHover := NewHover;
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
function TOverlayScrollBar.ThumbRect: TRect;
|
||||
var
|
||||
TrackTop, TrackH, ThumbH, Travel, ContentH: Integer;
|
||||
begin
|
||||
Result := Rect(0, 0, 0, 0);
|
||||
if (FMaximum <= 0) or (FViewportSize <= 0) then Exit;
|
||||
TrackTop := Scale96ToForm(4);
|
||||
TrackH := Height - 2 * TrackTop;
|
||||
if TrackH <= 0 then Exit;
|
||||
ContentH := FViewportSize + FMaximum;
|
||||
ThumbH := Max(Scale96ToForm(28),
|
||||
MulDiv(TrackH, FViewportSize, Max(1, ContentH)));
|
||||
ThumbH := Min(ThumbH, TrackH);
|
||||
Travel := TrackH - ThumbH;
|
||||
Result.Left := Max(1, (Width - Scale96ToForm(4)) div 2);
|
||||
Result.Right := Width - Result.Left;
|
||||
Result.Top := TrackTop;
|
||||
if (Travel > 0) and (FMaximum > 0) then
|
||||
Inc(Result.Top, MulDiv(Travel, FPosition, FMaximum));
|
||||
Result.Bottom := Result.Top + ThumbH;
|
||||
end;
|
||||
|
||||
procedure TOverlayScrollBar.Paint;
|
||||
var
|
||||
R: TRect;
|
||||
TrackX: Integer;
|
||||
begin
|
||||
Canvas.Brush.Style := bsSolid;
|
||||
Canvas.Brush.Color := FBGColor;
|
||||
Canvas.FillRect(ClientRect);
|
||||
if (FMaximum <= 0) or ((not FHover) and (not FDragging)) then Exit;
|
||||
|
||||
TrackX := Width div 2;
|
||||
Canvas.Pen.Color := FTrackColor;
|
||||
Canvas.Pen.Width := Max(1, Scale96ToForm(1));
|
||||
Canvas.Line(TrackX, Scale96ToForm(4),
|
||||
TrackX, Height - Scale96ToForm(4));
|
||||
|
||||
R := ThumbRect;
|
||||
if IsRectEmpty(R) then Exit;
|
||||
if FDragging then Canvas.Brush.Color := FThumbDragColor
|
||||
else Canvas.Brush.Color := FThumbColor;
|
||||
Canvas.Pen.Style := psClear;
|
||||
Canvas.RoundRect(R.Left, R.Top, R.Right, R.Bottom,
|
||||
Scale96ToForm(3), Scale96ToForm(3));
|
||||
Canvas.Pen.Style := psSolid;
|
||||
end;
|
||||
|
||||
procedure TOverlayScrollBar.MouseDown(Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: Integer);
|
||||
var
|
||||
R: TRect;
|
||||
begin
|
||||
inherited MouseDown(Button, Shift, X, Y);
|
||||
if (Button <> mbLeft) or (FMaximum <= 0) then Exit;
|
||||
R := ThumbRect;
|
||||
if PtInRect(R, Point(X, Y)) then
|
||||
begin
|
||||
FDragging := True;
|
||||
FDragY := Y;
|
||||
FDragPosition := FPosition;
|
||||
SetCaptureControl(Self);
|
||||
end
|
||||
else if Y < R.Top then
|
||||
ScrollBy(-FViewportSize + Scale96ToForm(40))
|
||||
else
|
||||
ScrollBy(FViewportSize - Scale96ToForm(40));
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
procedure TOverlayScrollBar.MouseMove(Shift: TShiftState; X, Y: Integer);
|
||||
var
|
||||
R: TRect;
|
||||
TrackH, Travel: Integer;
|
||||
begin
|
||||
inherited MouseMove(Shift, X, Y);
|
||||
if not FDragging then Exit;
|
||||
R := ThumbRect;
|
||||
TrackH := Height - 2 * Scale96ToForm(4);
|
||||
Travel := TrackH - (R.Bottom - R.Top);
|
||||
if Travel <= 0 then Exit;
|
||||
SetPosition(FDragPosition + MulDiv(Y - FDragY, FMaximum, Travel));
|
||||
end;
|
||||
|
||||
procedure TOverlayScrollBar.MouseUp(Button: TMouseButton;
|
||||
Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
inherited MouseUp(Button, Shift, X, Y);
|
||||
if Button <> mbLeft then Exit;
|
||||
FDragging := False;
|
||||
if GetCaptureControl = Self then SetCaptureControl(nil);
|
||||
Invalidate;
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user