mirror of
https://git.vladimir.cc/vladimir/ewsdr.git
synced 2026-08-25 20:37:33 +00:00
add FlatSlider
This commit is contained in:
+231
@@ -0,0 +1,231 @@
|
||||
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.
|
||||
Reference in New Issue
Block a user