ewsdr/FlatSlider.pas

unit FlatSlider;

{ Кастомный горизонтальный ползунок — замена TTrackBar.
  Полностью отрисован через Canvas, одинаково выглядит на Windows и Linux.
  Цвета настраиваемые: применяй SetThemeColors(T: TAppTheme) для смены темы. }

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Controls, Graphics, LCLType, Types, Math;

type
  TFlatSlider = class(TGraphicControl)
  private
    FMin:      Integer;
    FMax:      Integer;
    FPosition: Integer;
    FReversed: Boolean;
    FDragging: Boolean;
    FHot:      Boolean;
    FOnChange: TNotifyEvent;
    // Цвета (настраиваются через SetThemeColors или напрямую)
    FClrBG:         TColor;
    FClrTrackEmpty: TColor;
    FClrTrackFill:  TColor;
    FClrThumbNorm:  TColor;
    FClrThumbHot:   TColor;
    FClrThumbDrag:  TColor;
    FClrThumbBdr:   TColor;
    procedure SetPosition(V: Integer);
    procedure SetMin(V: Integer);
    procedure SetMax(V: Integer);
    function  PosToX(APos: Integer): Integer;
    function  XToPos(AX: Integer): Integer;
  protected
    procedure Paint; override;
    procedure MouseEnter; override;
    procedure MouseLeave; 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;
    function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
    function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
  public
    constructor Create(AOwner: TComponent); override;

    // Применить набор цветов из темы
    procedure SetThemeColors(
      ABG, ATrackEmpty, ATrackFill,
      AThumbNorm, AThumbHot, AThumbDrag, AThumbBdr: TColor);

    property Min:      Integer read FMin      write SetMin;
    property Max:      Integer read FMax      write SetMax;
    property Position: Integer read FPosition write SetPosition;
    property Reversed: Boolean read FReversed write FReversed;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Enabled;
    property Visible;
  end;

implementation

const
  THUMB_R = 6;
  TRACK_H = 4;
  PAD     = THUMB_R + 2;

constructor TFlatSlider.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FMin      := 0;
  FMax      := 100;
  FPosition := 0;
  FReversed := False;
  FDragging := False;
  FHot      := False;
  Cursor    := crHandPoint;
  // Тёмная тема по умолчанию
  FClrBG         := TColor($00181818);
  FClrTrackEmpty := TColor($00323232);
  FClrTrackFill  := TColor($00205018);
  FClrThumbNorm  := TColor($00407840);
  FClrThumbHot   := TColor($0066BB66);
  FClrThumbDrag  := TColor($0099EE99);
  FClrThumbBdr   := TColor($00122012);
end;

procedure TFlatSlider.SetThemeColors(
  ABG, ATrackEmpty, ATrackFill,
  AThumbNorm, AThumbHot, AThumbDrag, AThumbBdr: TColor);
begin
  FClrBG         := ABG;
  FClrTrackEmpty := ATrackEmpty;
  FClrTrackFill  := ATrackFill;
  FClrThumbNorm  := AThumbNorm;
  FClrThumbHot   := AThumbHot;
  FClrThumbDrag  := AThumbDrag;
  FClrThumbBdr   := AThumbBdr;
  Invalidate;
end;

procedure TFlatSlider.SetPosition(V: Integer);
var C: Integer;
begin
  C := EnsureRange(V, FMin, FMax);
  if FPosition = C then Exit;
  FPosition := C;
  Invalidate;
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TFlatSlider.SetMin(V: Integer);
begin
  if FMin = V then Exit;
  FMin := V;
  if FPosition < FMin then FPosition := FMin;
  Invalidate;
end;

procedure TFlatSlider.SetMax(V: Integer);
begin
  if FMax = V then Exit;
  FMax := V;
  if FPosition > FMax then FPosition := FMax;
  Invalidate;
end;

function TFlatSlider.PosToX(APos: Integer): Integer;
var Range, TrackW: Integer;
begin
  Range  := FMax - FMin;
  TrackW := Width - PAD * 2;
  if (Range <= 0) or (TrackW <= 0) then begin Result := PAD; Exit; end;
  if FReversed then
    Result := PAD + Round((FMax - APos) / Range * TrackW)
  else
    Result := PAD + Round((APos - FMin) / Range * TrackW);
end;

function TFlatSlider.XToPos(AX: Integer): Integer;
var Range, TrackW, RawX: Integer;
begin
  Range  := FMax - FMin;
  TrackW := Width - PAD * 2;
  RawX   := EnsureRange(AX - PAD, 0, TrackW);
  if (TrackW <= 0) or (Range <= 0) then begin Result := FMin; Exit; end;
  if FReversed then
    Result := FMax - Round(RawX / TrackW * Range)
  else
    Result := FMin + Round(RawX / TrackW * Range);
  Result := EnsureRange(Result, FMin, FMax);
end;

procedure TFlatSlider.Paint;
var
  CY, TX, FL, FR: Integer;
  TR: TRect;
  ThC: TColor;
begin
  CY := Height div 2;
  TX := PosToX(FPosition);

  Canvas.Brush.Color := FClrBG;
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Style   := psClear;
  Canvas.FillRect(ClientRect);

  TR := Rect(PAD, CY - TRACK_H div 2,
             Width - PAD, CY + (TRACK_H + 1) div 2);
  Canvas.Brush.Color := FClrTrackEmpty;
  Canvas.RoundRect(TR.Left, TR.Top, TR.Right, TR.Bottom, TRACK_H, TRACK_H);

  if not FReversed then begin FL := PAD; FR := TX; end
  else                  begin FL := TX;  FR := Width - PAD; end;
  if FR > FL then
  begin
    Canvas.Brush.Color := FClrTrackFill;
    Canvas.RoundRect(FL, TR.Top, FR, TR.Bottom, TRACK_H, TRACK_H);
  end;

  if      FDragging then ThC := FClrThumbDrag
  else if FHot      then ThC := FClrThumbHot
  else                   ThC := FClrThumbNorm;
  Canvas.Brush.Color := ThC;
  Canvas.Pen.Color   := FClrThumbBdr;
  Canvas.Pen.Style   := psSolid;
  Canvas.Pen.Width   := 1;
  Canvas.Ellipse(TX - THUMB_R, CY - THUMB_R,
                 TX + THUMB_R + 1, CY + THUMB_R + 1);
end;

procedure TFlatSlider.MouseEnter;
begin
  inherited;
  FHot := True;
  Invalidate;
end;

procedure TFlatSlider.MouseLeave;
begin
  inherited;
  FHot := False;
  Invalidate;
end;

procedure TFlatSlider.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  if Button = mbLeft then
  begin
    FDragging := True;
    SetPosition(XToPos(X));
  end;
end;

procedure TFlatSlider.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if FDragging then
    SetPosition(XToPos(X));
end;

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

function TFlatSlider.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
  SetPosition(FPosition + 1);
  Result := True;
end;

function TFlatSlider.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
  SetPosition(FPosition - 1);
  Result := True;
end;

end.