ewsdr/OverlayScrollBar.pas

{
  Copyright (C)
  2026 - Uladzimir Karpenka, EW8BAK

  This program is free software; you can redistribute it and/or
  modify it under the terms of the GNU General Public License
  as published by the Free Software Foundation; either version 2
  of the License, or (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
}

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.