unit FlatSeekBarPro;
{$mode ObjFPC}{$H+}
interface
uses
Classes, SysUtils, Controls, Graphics, LMessages, Types, LCLType,
BGRABitmap, BGRABitmapTypes;
type
TFlatSeekBarPro = class(TCustomControl)
private
FValue: integer;
FMin: integer;
FMax: integer;
FDragging: boolean;
FHovering: boolean;
FMouseDownOnKnob: boolean;
FTrackColor: TColor;
FTrackBorderWidth: integer;
FKnobColor: TColor;
FKnobHoverColor: TColor;
FKnobBorderColor: TColor;
FKnobBorderWidth: integer;
FKnobRadius: integer;
FLeftMargin: integer;
FRightMargin: integer;
FOnChange: TNotifyEvent;
FOnMouseDown: TMouseEvent;
FOnMouseMove: TMouseMoveEvent;
FOnMouseUp: TMouseEvent;
procedure SetValue(AValue: integer);
function ValueToPosition(Value: integer): integer;
function PositionToValue(X: integer): integer;
procedure SetTrackColor(AColor: TColor);
procedure SetKnobColor(AColor: TColor);
procedure SetKnobHoverColor(AColor: TColor);
procedure SetKnobBorderColor(AColor: TColor);
procedure SetKnobRadius(ARadius: integer);
procedure SetTrackBorderWidth(AValue: integer);
procedure SetKnobBorderWidth(AValue: integer);
procedure SetLeftMargin(AValue: integer);
procedure SetRightMargin(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;
public
constructor Create(AOwner: TComponent); override;
published
property Min: integer read FMin write FMin default 0;
property Max: integer read FMax write FMax default 100;
property Value: integer read FValue write SetValue default 0;
property TrackColor: TColor read FTrackColor write SetTrackColor default clGray;
property TrackBorderWidth: integer read FTrackBorderWidth
write SetTrackBorderWidth default 2;
property KnobColor: TColor read FKnobColor write SetKnobColor default clWhite;
property KnobHoverColor: TColor
read FKnobHoverColor write SetKnobHoverColor default clSilver;
property KnobBorderColor: TColor read FKnobBorderColor
write SetKnobBorderColor default clBlack;
property KnobBorderWidth: integer read FKnobBorderWidth
write SetKnobBorderWidth default 2;
property KnobRadius: integer read FKnobRadius write SetKnobRadius default 7;
property LeftMargin: integer read FLeftMargin write SetLeftMargin default 10;
property RightMargin: integer read FRightMargin write SetRightMargin default 10;
property Align;
property Anchors;
property Color;
property ParentColor;
property Visible;
property Enabled;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnMouseDown: TMouseEvent read FOnMouseDown write FOnMouseDown;
property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
property OnMouseUp: TMouseEvent read FOnMouseUp write FOnMouseUp;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('PSDesign', [TFlatSeekBarPro]);
end;
{ TFlatSeekBarPro }
constructor TFlatSeekBarPro.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 150;
Height := 30;
FMin := 0;
FMax := 100;
FValue := 0;
FDragging := False;
FHovering := False;
FMouseDownOnKnob := False;
FTrackColor := clGray;
FTrackBorderWidth := 2;
FKnobColor := clWhite;
FKnobHoverColor := clSilver;
FKnobBorderColor := clBlack;
FKnobBorderWidth := 2;
FKnobRadius := 7;
FLeftMargin := 10;
FRightMargin := 10;
Color := clDefault;
DoubleBuffered := True;
end;
procedure TFlatSeekBarPro.SetValue(AValue: integer);
begin
if AValue < FMin then AValue := FMin;
if AValue > FMax then AValue := FMax;
if FValue <> AValue then
begin
FValue := AValue;
Invalidate;
if Assigned(FOnChange) then
FOnChange(Self);
end;
end;
function TFlatSeekBarPro.ValueToPosition(Value: integer): integer;
begin
if FMax = FMin then Exit(FLeftMargin);
Result := FLeftMargin + Round((ClientWidth - FLeftMargin - FRightMargin) *
(Value - FMin) / (FMax - FMin));
end;
function TFlatSeekBarPro.PositionToValue(X: integer): integer;
begin
Result := FMin + Round((X - FLeftMargin) * (FMax - FMin) /
(ClientWidth - FLeftMargin - FRightMargin));
if Result < FMin then Result := FMin;
if Result > FMax then Result := FMax;
end;
procedure TFlatSeekBarPro.Paint;
var
bmp: TBGRABitmap;
cx, cy, r: integer;
borderColor, bgColor: TBGRAPixel;
rawColor: TColor;
begin
// Pobierz rzeczywisty kolor tła
if Color = clDefault then
begin
if ParentColor and Assigned(Parent) then
rawColor := Parent.Color
else
rawColor := clBtnFace; // fallback
end
else
rawColor := Color;
bgColor := ColorToBGRA(rawColor);
bmp := TBGRABitmap.Create(ClientWidth, ClientHeight, bgColor);
try
cx := ValueToPosition(FValue);
cy := Height div 2;
r := FKnobRadius;
// Track
bmp.CanvasBGRA.Pen.Width := FTrackBorderWidth;
bmp.CanvasBGRA.Pen.Style := psSolid;
bmp.CanvasBGRA.Pen.Color := ColorToBGRA(FTrackColor);
bmp.CanvasBGRA.Line(FLeftMargin, cy, ClientWidth - FRightMargin, cy);
// Knob color
if FMouseDownOnKnob or FHovering then
knobColor := ColorToBGRA(FKnobHoverColor)
else
knobColor := ColorToBGRA(FKnobColor);
borderColor := ColorToBGRA(FKnobBorderColor);
// Knob
bmp.FillEllipseAntialias(cx, cy, r, r, knobColor);
if FKnobBorderWidth > 0 then
bmp.EllipseAntialias(cx, cy, r, r, borderColor, FKnobBorderWidth);
bmp.Draw(Canvas, 0, 0, True);
finally
bmp.Free;
end;
end;
procedure TFlatSeekBarPro.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: integer);
var
cx, cy, r: integer;
begin
inherited MouseDown(Button, Shift, X, Y);
if Assigned(FOnMouseDown) then
FOnMouseDown(Self, Button, Shift, X, Y);
if Button = mbLeft then
begin
FDragging := True;
SetValue(PositionToValue(X));
cx := ValueToPosition(FValue);
cy := Height div 2;
r := FKnobRadius;
FMouseDownOnKnob := PtInRect(Rect(cx - r, cy - r, cx + r, cy + r), Point(X, Y));
Invalidate;
end;
end;
procedure TFlatSeekBarPro.MouseMove(Shift: TShiftState; X, Y: integer);
begin
inherited MouseMove(Shift, X, Y);
if Assigned(FOnMouseMove) then
FOnMouseMove(Self, Shift, X, Y);
if FDragging then
SetValue(PositionToValue(X));
end;
procedure TFlatSeekBarPro.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer);
begin
inherited MouseUp(Button, Shift, X, Y);
if Assigned(FOnMouseUp) then
FOnMouseUp(Self, Button, Shift, X, Y);
FDragging := False;
FMouseDownOnKnob := False;
Invalidate;
end;
procedure TFlatSeekBarPro.MouseEnter;
begin
inherited MouseEnter;
FHovering := True;
Invalidate;
end;
procedure TFlatSeekBarPro.MouseLeave;
begin
inherited MouseLeave;
FHovering := False;
Invalidate;
end;
procedure TFlatSeekBarPro.SetTrackColor(AColor: TColor);
begin
if FTrackColor <> AColor then
begin
FTrackColor := AColor;
Invalidate;
end;
end;
procedure TFlatSeekBarPro.SetTrackBorderWidth(AValue: integer);
begin
if FTrackBorderWidth <> AValue then
begin
FTrackBorderWidth := AValue;
Invalidate;
end;
end;
procedure TFlatSeekBarPro.SetKnobColor(AColor: TColor);
begin
if FKnobColor <> AColor then
begin
FKnobColor := AColor;
Invalidate;
end;
end;
procedure TFlatSeekBarPro.SetKnobHoverColor(AColor: TColor);
begin
if FKnobHoverColor <> AColor then
begin
FKnobHoverColor := AColor;
Invalidate;
end;
end;
procedure TFlatSeekBarPro.SetKnobBorderColor(AColor: TColor);
begin
if FKnobBorderColor <> AColor then
begin
FKnobBorderColor := AColor;
Invalidate;
end;
end;
procedure TFlatSeekBarPro.SetKnobBorderWidth(AValue: integer);
begin
if FKnobBorderWidth <> AValue then
begin
FKnobBorderWidth := AValue;
Invalidate;
end;
end;
procedure TFlatSeekBarPro.SetKnobRadius(ARadius: integer);
begin
if (ARadius > 1) and (FKnobRadius <> ARadius) then
begin
FKnobRadius := ARadius;
Invalidate;
end;
end;
procedure TFlatSeekBarPro.SetLeftMargin(AValue: integer);
begin
if FLeftMargin <> AValue then
begin
FLeftMargin := AValue;
Invalidate;
end;
end;
procedure TFlatSeekBarPro.SetRightMargin(AValue: integer);
begin
if FRightMargin <> AValue then
begin
FRightMargin := AValue;
Invalidate;
end;
end;
end.
Recent
