ewsdr/FlatSlider.pas

unit FlatSlider;

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

{$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;
    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;

    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;             // радиус ручки (px)
  TRACK_H = 4;             // высота рельса (px)
  PAD     = THUMB_R + 2;  // боковой отступ чтобы ручка не вылезала

  CLR_BG          = TColor($00181818);  // совпадает с CLR_PANEL
  CLR_TRACK_EMPTY = TColor($00323232);
  CLR_TRACK_FILL  = TColor($00205018);  // тёмно-зелёный, как тема
  CLR_THUMB_NORM  = TColor($00407840);
  CLR_THUMB_HOT   = TColor($0066BB66);
  CLR_THUMB_DRAG  = TColor($0099EE99);
  CLR_THUMB_BDR   = TColor($00122012);

constructor TFlatSlider.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FMin      := 0;
  FMax      := 100;
  FPosition := 0;
  FReversed := False;
  FDragging := False;
  FHot      := False;
  Cursor    := crHandPoint;
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;

// Позиция значения → пиксельная X-координата ручки
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;

// Пиксельная X-координата → значение позиции
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 := CLR_BG;
  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 := CLR_TRACK_EMPTY;
  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 := CLR_TRACK_FILL;
    Canvas.RoundRect(FL, TR.Top, FR, TR.Bottom, TRACK_H, TRACK_H);
  end;

  // Ручка — круг
  if      FDragging then ThC := CLR_THUMB_DRAG
  else if FHot      then ThC := CLR_THUMB_HOT
  else                   ThC := CLR_THUMB_NORM;
  Canvas.Brush.Color := ThC;
  Canvas.Pen.Color   := CLR_THUMB_BDR;
  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.