nlve/src/uThemedScroll.pas

{
  uThemedScroll — полоса прокрутки, нарисованная своими силами, и обвязка
  для таблиц.

  Зачем. Полосы прокрутки у обычных элементов рисует система, и цвет им
  задать нечем: на тёмном окне они остаются светлыми. Единственный способ
  получить их в своих цветах — не пользоваться системными вовсе.

  Таблица при этом остаётся обычной: у неё выключаются собственные полосы,
  а прокрутка задаётся свойствами TopRow и LeftCol. Переписывать саму
  таблицу не требуется.

  Ограничение, о котором надо знать: по горизонтали прокрутка идёт
  столбцами, а не пикселями. Так устроено свойство LeftCol, и мельче
  сдвинуть содержимое нечем.
}
unit uThemedScroll;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Types, Controls, Graphics, StdCtrls, Grids, LCLType;

type

  TThemedScrollBar = class(TCustomControl)
  private
    FVertical: Boolean;
    FTotal: Integer;
    FPage: Integer;
    FPosition: Integer;
    FHover: Boolean;
    FDragging: Boolean;
    FDragOffset: Integer;
    FOnChange: TNotifyEvent;
    function TrackSize: Integer;
    function ThumbSize: Integer;
    function MaxPosition: Integer;
    function ThumbRect: TRect;
    procedure SetPosition(AValue: Integer);
  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;
    procedure MouseEnter; override;
    procedure MouseLeave; override;
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      MousePos: TPoint): Boolean; override;
  public
    constructor Create(AOwner: TComponent); override;

    { Направление задаётся один раз при создании. }
    procedure Setup(AVertical: Boolean);

    { ATotal — сколько всего, APage — сколько видно за раз. Положение
      меняется в пределах от нуля до ATotal минус APage. }
    procedure SetRange(ATotal, APage: Integer);

    { Нужна ли полоса вообще: если видно всё, она только занимает место. }
    function Needed: Boolean;

    property Position: Integer read FPosition write SetPosition;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

{ Заменяет системные полосы таблицы на свои.

  Таблица переселяется внутрь контейнера, который встаёт на её место и
  забирает себе её выравнивание. Так работает и с таблицей, растянутой по
  всему окну, и с прикреплённой к краям. }
procedure AttachThemedScrollBars(AGrid: TStringGrid);

implementation

uses
  uTheme;

const
  BarSize = 12;
  MinThumb = 24;
  WheelRows = 3;

type
  { Контейнер: таблица плюс две полосы. }
  TScrolledGrid = class(TCustomControl)
  private
    FGrid: TStringGrid;
    FVBar: TThemedScrollBar;
    FHBar: TThemedScrollBar;
    FUpdating: Boolean;
    { Глубина вложенности пересчёта размещения. Ограничена: см. SyncBars. }
    FDepth: Integer;
    { Сколько места занимает всё содержимое таблицы. Считается сложением
      ширин столбцов и высот строк, а не свойствами GridWidth и
      GridHeight: с выключенными полосами прокрутки те возвращают не
      полный размер содержимого, и полосы никогда не появлялись. }
    function ContentWidth: Integer;
    function ContentHeight: Integer;
    procedure Relayout;
    procedure SyncBars;
    procedure GridTopLeftChanged(Sender: TObject);
    procedure VBarChange(Sender: TObject);
    procedure HBarChange(Sender: TObject);
    procedure GridWheel(Sender: TObject; Shift: TShiftState;
      WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
  protected
    procedure Paint; override;
    procedure Resize; override;
  public
    constructor CreateFor(AGrid: TStringGrid);
  end;

{ TThemedScrollBar }

constructor TThemedScrollBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FVertical := True;
  FTotal := 0;
  FPage := 1;
  DoubleBuffered := True;
  ControlStyle := ControlStyle + [csOpaque];
  { Цвет задаём и самому контролу: пока не дошло дело до нашей отрисовки,
    виджетсет закрашивает его своим, и на тёмном окне это заметно. }
  Color := ThemeWindow;
end;

procedure TThemedScrollBar.Setup(AVertical: Boolean);
begin
  FVertical := AVertical;
end;

function TThemedScrollBar.MaxPosition: Integer;
begin
  Result := FTotal - FPage;
  if Result < 0 then
    Result := 0;
end;

function TThemedScrollBar.Needed: Boolean;
begin
  Result := FTotal > FPage;
end;

procedure TThemedScrollBar.SetRange(ATotal, APage: Integer);
begin
  if APage < 1 then
    APage := 1;
  if ATotal < 0 then
    ATotal := 0;
  FTotal := ATotal;
  FPage := APage;
  if FPosition > MaxPosition then
    FPosition := MaxPosition;
  Invalidate;
end;

procedure TThemedScrollBar.SetPosition(AValue: Integer);
begin
  if AValue > MaxPosition then
    AValue := MaxPosition;
  if AValue < 0 then
    AValue := 0;
  if AValue = FPosition then
    Exit;
  FPosition := AValue;
  Invalidate;
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

function TThemedScrollBar.TrackSize: Integer;
begin
  if FVertical then
    Result := Height
  else
    Result := Width;
  if Result < 1 then
    Result := 1;
end;

function TThemedScrollBar.ThumbSize: Integer;
begin
  if FTotal <= 0 then
    Exit(TrackSize);
  Result := Round(TrackSize * FPage / FTotal);
  if Result < MinThumb then
    Result := MinThumb;
  if Result > TrackSize then
    Result := TrackSize;
end;

function TThemedScrollBar.ThumbRect: TRect;
var
  Size, Offset, Span: Integer;
begin
  Size := ThumbSize;
  Span := MaxPosition;
  if Span > 0 then
    Offset := Round((TrackSize - Size) * FPosition / Span)
  else
    Offset := 0;

  if FVertical then
    Result := Rect(0, Offset, Width, Offset + Size)
  else
    Result := Rect(Offset, 0, Offset + Size, Height);
end;

procedure TThemedScrollBar.Paint;
var
  T: TRect;
  Fill: TColor;
begin
  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := ThemeWindow;
  Canvas.FillRect(ClientRect);

  if not Needed then
    Exit;

  if FDragging or FHover then
    Fill := ThemeButtonHover
  else
    Fill := ThemeButton;

  T := ThumbRect;
  Canvas.Brush.Color := Fill;
  if FVertical then
    Canvas.FillRect(T.Left + 2, T.Top + 1, T.Right - 2, T.Bottom - 1)
  else
    Canvas.FillRect(T.Left + 1, T.Top + 2, T.Right - 1, T.Bottom - 2);
end;

procedure TThemedScrollBar.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  T: TRect;
  Along: Integer;
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button <> mbLeft) or (not Needed) then
    Exit;

  T := ThumbRect;
  if PtInRect(T, Point(X, Y)) then
  begin
    FDragging := True;
    if FVertical then
      FDragOffset := Y - T.Top
    else
      FDragOffset := X - T.Left;
    Invalidate;
    Exit;
  end;

  { Щелчок мимо ползунка листает на страницу — так ведёт себя привычная
    полоса прокрутки. }
  if FVertical then
    Along := Y
  else
    Along := X;
  if FVertical then
  begin
    if Along < T.Top then
      Position := FPosition - FPage
    else
      Position := FPosition + FPage;
  end
  else
  begin
    if Along < T.Left then
      Position := FPosition - FPage
    else
      Position := FPosition + FPage;
  end;
end;

procedure TThemedScrollBar.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  Size, Span, Along: Integer;
begin
  inherited MouseMove(Shift, X, Y);
  if not FDragging then
    Exit;

  Size := ThumbSize;
  Span := TrackSize - Size;
  if Span <= 0 then
    Exit;

  if FVertical then
    Along := Y - FDragOffset
  else
    Along := X - FDragOffset;

  Position := Round(Along * MaxPosition / Span);
end;

procedure TThemedScrollBar.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  FDragging := False;
  Invalidate;
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TThemedScrollBar.MouseEnter;
begin
  inherited MouseEnter;
  FHover := True;
  Invalidate;
end;

procedure TThemedScrollBar.MouseLeave;
begin
  inherited MouseLeave;
  FHover := False;
  Invalidate;
end;

function TThemedScrollBar.DoMouseWheel(Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint): Boolean;
begin
  if WheelDelta > 0 then
    Position := FPosition - WheelRows
  else
    Position := FPosition + WheelRows;
  Result := True;
end;

{ TScrolledGrid }

constructor TScrolledGrid.CreateFor(AGrid: TStringGrid);
begin
  inherited Create(AGrid.Owner);
  FGrid := AGrid;

  { Контейнер встаёт ровно на место таблицы и забирает её выравнивание:
    иначе при изменении размеров окна они разъедутся. }
  Parent := AGrid.Parent;
  SetBounds(AGrid.Left, AGrid.Top, AGrid.Width, AGrid.Height);
  Anchors := AGrid.Anchors;
  Align := AGrid.Align;

  { Полосы создаются раньше, чем таблице назначаются обработчики. Иначе
    первое же событие таблицы вызовет согласование с полосами, которых
    ещё нет, и программа упадёт с «Access violation». }
  FVBar := TThemedScrollBar.Create(Self);
  FVBar.Parent := Self;
  FVBar.Setup(True);
  FVBar.OnChange := @VBarChange;

  FHBar := TThemedScrollBar.Create(Self);
  FHBar.Parent := Self;
  FHBar.Setup(False);
  FHBar.OnChange := @HBarChange;

  FGrid.Parent := Self;
  FGrid.Align := alNone;
  FGrid.Anchors := [akTop, akLeft];
  FGrid.ScrollBars := ssNone;
  FGrid.OnTopLeftChanged := @GridTopLeftChanged;
  FGrid.OnMouseWheel := @GridWheel;

  Relayout;
end;

function TScrolledGrid.ContentWidth: Integer;
var
  I: Integer;
begin
  Result := 0;
  for I := 0 to FGrid.ColCount - 1 do
    Inc(Result, FGrid.ColWidths[I]);
end;

function TScrolledGrid.ContentHeight: Integer;
var
  I: Integer;
begin
  Result := 0;
  for I := 0 to FGrid.RowCount - 1 do
    Inc(Result, FGrid.RowHeights[I]);
end;

procedure TScrolledGrid.Paint;
begin
  { Виден только уголок между полосами. }
  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := ThemeWindow;
  Canvas.FillRect(ClientRect);
end;

procedure TScrolledGrid.Resize;
begin
  inherited Resize;
  Relayout;
end;

procedure TScrolledGrid.Relayout;
var
  W, H: Integer;
  NeedV, NeedH: Boolean;
begin
  if (FGrid = nil) or (FVBar = nil) or (FHBar = nil) or FUpdating then
    Exit;
  FUpdating := True;
  try
    W := ClientWidth;
    H := ClientHeight;
    if (W < 1) or (H < 1) then
      Exit;

    { Считаем в два захода: место, занятое одной полосой, может сделать
      нужной вторую. }
    { Два захода: место, занятое одной полосой, может сделать нужной
      вторую. }
    NeedV := ContentHeight > H;
    NeedH := ContentWidth > W;
    if NeedV then
      Dec(W, BarSize);
    if NeedH then
      Dec(H, BarSize);
    if (not NeedV) and (ContentHeight > H) then
    begin
      NeedV := True;
      Dec(W, BarSize);
    end;
    if (not NeedH) and (ContentWidth > W) then
    begin
      NeedH := True;
      Dec(H, BarSize);
    end;

    FGrid.SetBounds(0, 0, W, H);

    FVBar.Visible := NeedV;
    if NeedV then
      FVBar.SetBounds(W, 0, BarSize, H);

    FHBar.Visible := NeedH;
    if NeedH then
      FHBar.SetBounds(0, H, W, BarSize);

    { После перестановки границ перерисовка не назначается сама. }
    FVBar.Invalidate;
    FHBar.Invalidate;
  finally
    FUpdating := False;
  end;
  SyncBars;
end;

procedure TScrolledGrid.SyncBars;
var
  NeedRelayout: Boolean;
begin
  if (FGrid = nil) or (FVBar = nil) or (FHBar = nil) or FUpdating then
    Exit;
  FUpdating := True;
  try
    FVBar.SetRange(FGrid.RowCount - FGrid.FixedRows, FGrid.VisibleRowCount);
    FVBar.Position := FGrid.TopRow - FGrid.FixedRows;
    FHBar.SetRange(FGrid.ColCount - FGrid.FixedCols, FGrid.VisibleColCount);
    FHBar.Position := FGrid.LeftCol - FGrid.FixedCols;
    { Строки в таблицу добавляются уже после её создания, и нужность полос
      от этого меняется. Без этой проверки они пересчитывались бы только
      при изменении размеров окна. }
    NeedRelayout := (FVBar.Visible <> FVBar.Needed) or
      (FHBar.Visible <> FHBar.Needed);
  finally
    FUpdating := False;
  end;
  { Пересчёт размещения сам вызовет согласование ещё раз.

    Обещать, что второго круга не будет, нельзя, и это стоило падения:
    появление вертикальной полосы сужает таблицу, от этого перестаёт
    помещаться содержимое по ширине, появляется горизонтальная полоса,
    от неё убавляется высота — и решение о вертикальной принимается
    заново. Под Wine эти качели не сходились никогда: стек в шестнадцать
    мегабайт съедался целиком, и программа падала при открытии окна
    зависимостей.

    Поэтому глубина ограничена. Три круга хватает любому разумному
    случаю, а на четвёртом мы просто оставляем как есть: лишняя полоса
    прокрутки не беда, а падение — беда. }
  if NeedRelayout and (FDepth < 3) then
  begin
    Inc(FDepth);
    try
      Relayout;
    finally
      Dec(FDepth);
    end;
  end;
end;

procedure TScrolledGrid.GridTopLeftChanged(Sender: TObject);
begin
  SyncBars;
end;

procedure TScrolledGrid.VBarChange(Sender: TObject);
begin
  if FUpdating then
    Exit;
  FUpdating := True;
  try
    FGrid.TopRow := FVBar.Position + FGrid.FixedRows;
  finally
    FUpdating := False;
  end;
end;

procedure TScrolledGrid.HBarChange(Sender: TObject);
begin
  if FUpdating then
    Exit;
  FUpdating := True;
  try
    FGrid.LeftCol := FHBar.Position + FGrid.FixedCols;
  finally
    FUpdating := False;
  end;
end;

procedure TScrolledGrid.GridWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
  { Без собственных полос таблица колесо не обрабатывает, поэтому крутим
    сами. }
  if WheelDelta > 0 then
    FGrid.TopRow := FGrid.TopRow - WheelRows
  else
    FGrid.TopRow := FGrid.TopRow + WheelRows;
  Handled := True;
  SyncBars;
end;

procedure AttachThemedScrollBars(AGrid: TStringGrid);
begin
  if (AGrid = nil) or (AGrid.Parent = nil) then
    Exit;
  TScrolledGrid.CreateFor(AGrid);
end;

end.