6b58ffe795
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6850 8e941d3f-bd1b-0410-a28a-d453659cc2b4
854 lines
27 KiB
ObjectPascal
854 lines
27 KiB
ObjectPascal
{
|
|
/***************************************************************************
|
|
indSliders
|
|
----------
|
|
sliders for the Industrial package
|
|
|
|
The initial version of this unit was published in the Lazarus forum
|
|
by user bylaardt
|
|
(https://forum.lazarus.freepascal.org/index.php/topic,45063.msg318180.html#msg318180)
|
|
and extended by wp.
|
|
|
|
License: modified LGPL like Lazarus LCL
|
|
*****************************************************************************
|
|
}
|
|
|
|
unit indSliders;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, Graphics, Controls, Types;
|
|
|
|
const
|
|
DEFAULT_SIZE = 28;
|
|
DEFAULT_TRACK_THICKNESS = 7;
|
|
DEFAULT_MULTISLIDER_WIDTH = 250;
|
|
DEFAULT_MULTISLIDER_HEIGHT = DEFAULT_SIZE * 5 div 4;
|
|
|
|
Type
|
|
|
|
{ TMultiSlider }
|
|
|
|
TSliderMode = (smSingle, smMinMax, smMinValueMax);
|
|
|
|
TThumbKind = (tkMin, tkMax, tkValue);
|
|
|
|
TThumbstyle = (tsGrip, tsCircle, tsRect, tsRoundedRect,
|
|
tsTriangle, tsTriangleOtherSide);
|
|
|
|
TSliderPositionEvent = procedure (
|
|
Sender: TObject; AKind: TThumbKind; AValue: Integer) of object;
|
|
|
|
TMultiSlider = class(TCustomControl)
|
|
private
|
|
FAutoRotate: Boolean;
|
|
FTrackSize: TPoint;
|
|
FBtnSize: TPoint;
|
|
FCapture: ShortInt;
|
|
FCaptureOffset, FTrackStart: Integer;
|
|
FColorAbove: TColor;
|
|
FColorBelow: TColor;
|
|
FColorBetween: TColor;
|
|
FColorThumb: TColor;
|
|
FFlat: Boolean;
|
|
FVertical: boolean;
|
|
FMaxPosition, FMinPosition, FPosition: Integer;
|
|
FDefaultSize: Integer;
|
|
FSliderMode: TSliderMode;
|
|
FThumbStyle: TThumbstyle;
|
|
FTrackThickness: Integer;
|
|
FOnPositionChange: TSliderPositionEvent;
|
|
FRangeMax, FRangeMin: Integer;
|
|
function IsDefaultSizeStored: Boolean;
|
|
function IsTrackThicknessStored: Boolean;
|
|
procedure SetColorAbove(AValue: TColor);
|
|
procedure SetColorBelow(AValue: TColor);
|
|
procedure SetColorBetween(AValue: TColor);
|
|
procedure SetColorThumb(AValue: TColor);
|
|
procedure SetDefaultSize(AValue: Integer);
|
|
procedure SetFlat(AValue: Boolean);
|
|
procedure SetMaxPosition(AValue: Integer);
|
|
procedure SetMinPosition(AValue: Integer);
|
|
procedure SetPosition(AValue: Integer);
|
|
procedure SetRangeMax(AValue: Integer);
|
|
procedure SetRangeMin(AValue: Integer);
|
|
procedure SetSliderMode(AValue: TSliderMode);
|
|
procedure SetThumbStyle(AValue: TThumbStyle);
|
|
procedure SetTrackThickness(AValue: Integer);
|
|
procedure SetVertical(AValue: Boolean);
|
|
protected
|
|
function BtnLength: Integer;
|
|
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
|
|
const AXProportion, AYProportion: Double); override;
|
|
procedure DoPositionChange(AKind: TThumbKind; AValue: Integer);
|
|
function ExtendedThumbs: Boolean;
|
|
function GetRectFromPoint(APosition: Integer; Alignment: TAlignment): TRect;
|
|
function GetThumbCenter(ARect: TRect): TPoint;
|
|
function GetTrackLength: Integer;
|
|
function IsInFirstHalf(APoint: TPoint; ARect: TRect): Boolean;
|
|
procedure Loaded; override;
|
|
function PointToPosition(P: TPoint): Integer;
|
|
procedure UpdateBounds;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Paint; override;
|
|
procedure Resize; 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 MouseLeave; override;
|
|
|
|
published
|
|
property AutoRotate: Boolean
|
|
read FAutoRotate write FAutoRotate default true;
|
|
property ColorAbove: TColor
|
|
read FColorAbove write SetColorAbove default clInactiveCaption;
|
|
property ColorBelow: TColor
|
|
read FColorBelow write SetColorBelow default clInactiveCaption;
|
|
property ColorBetween: TColor
|
|
read FColorBetween write SetColorBetween default clActiveCaption;
|
|
property ColorThumb: TColor
|
|
read FColorThumb write SetColorThumb default clBtnFace;
|
|
property DefaultSize: Integer
|
|
read FDefaultSize write SetDefaultSize stored IsDefaultSizeStored;
|
|
property Flat: Boolean
|
|
read FFlat write SetFlat default false;
|
|
property MaxPosition: Integer
|
|
read FMaxPosition write SetMaxPosition default 80;
|
|
property MinPosition: Integer
|
|
read FMinPosition write SetMinPosition default 20;
|
|
property Position: Integer
|
|
read FPosition write SetPosition default 50;
|
|
property RangeMax: Integer
|
|
read FRangeMax write SetRangeMax default 100;
|
|
property RangeMin: Integer
|
|
read FRangeMin write SetRangeMin default 0;
|
|
property SliderMode: TSliderMode
|
|
read FSliderMode write SetSliderMode default smMinMax;
|
|
property ThumbStyle: TThumbStyle
|
|
read FThumbStyle write SetThumbStyle default tsGrip;
|
|
property TrackThickness: integer
|
|
read FTrackThickness write SetTrackThickness stored IsTrackThicknessStored;
|
|
property Vertical: boolean
|
|
read FVertical write SetVertical default false;
|
|
|
|
property Height default DEFAULT_SIZE;
|
|
property Width default DEFAULT_MULTISLIDER_WIDTH;
|
|
property OnPositionChange: TSliderPositionEvent
|
|
read FOnPositionChange write FOnPositionChange;
|
|
|
|
property Align;
|
|
property BorderSpacing;
|
|
property Constraints;
|
|
property Enabled;
|
|
// property Font;
|
|
property HelpContext;
|
|
property HelpKeyword;
|
|
property HelpType;
|
|
property Left;
|
|
// property ParentFont;
|
|
property ParentShowHint;
|
|
property PopupMenu;
|
|
property ShowHint;
|
|
property Tag;
|
|
property Top;
|
|
property Visible;
|
|
|
|
property OnChangeBounds;
|
|
property OnClick;
|
|
property OnContextPopup;
|
|
property OnDblClick;
|
|
property OnMouseDown;
|
|
property OnMouseEnter;
|
|
property OnMouseLeave;
|
|
property OnMouseMove;
|
|
property OnMouseUp;
|
|
property OnMouseWheel;
|
|
property OnMouseWheelDown;
|
|
property OnMouseWheelUp;
|
|
property OnMouseWheelHorz;
|
|
property OnMouseWheelLeft;
|
|
property OnMouseWheelRight;
|
|
property OnResize;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
Math;
|
|
|
|
constructor TMultiSlider.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
|
|
FAutoRotate := true;
|
|
FCapture := -1;
|
|
FColorAbove := clInactiveCaption;
|
|
FColorBelow := clInactiveCaption;
|
|
FColorBetween := clActiveCaption;
|
|
FColorThumb := clBtnFace;
|
|
FDefaultSize := Scale96ToFont(DEFAULT_SIZE);
|
|
FTrackThickness := Scale96ToFont(DEFAULT_TRACK_THICKNESS);
|
|
FTrackStart := FDefaultSize*9 div 16 + 2;
|
|
SetVertical(false);
|
|
FRangeMin := 0;
|
|
FRangeMax := 100;
|
|
FMinPosition := 20;
|
|
FMaxPosition := 80;
|
|
FPosition := 50;
|
|
FSliderMode := smMinMax;
|
|
|
|
Width := DEFAULT_MULTISLIDER_WIDTH;
|
|
Height := DEFAULT_MULTISLIDER_HEIGHT;
|
|
Enabled := true;
|
|
end;
|
|
|
|
destructor TMultiSlider.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TMultiSlider.BtnLength: Integer;
|
|
begin
|
|
Result := IfThen(FVertical, FBtnSize.Y, FBtnSize.X) div 2;
|
|
end;
|
|
|
|
procedure TMultiSlider.DoAutoAdjustLayout(
|
|
const AMode: TLayoutAdjustmentPolicy;
|
|
const AXProportion, AYProportion: Double);
|
|
begin
|
|
inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion);
|
|
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
|
|
begin
|
|
DisableAutosizing;
|
|
try
|
|
if IsTrackThicknessStored then
|
|
if FVertical then
|
|
FTrackThickness := Round(FTrackThickness * AXProportion)
|
|
else
|
|
FTrackThickness := Round(FTrackThickness * AYProportion);
|
|
finally
|
|
EnableAutoSizing;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TMultiSlider.DoPositionChange(AKind: TThumbKind; AValue: Integer);
|
|
begin
|
|
if Assigned(FOnPositionChange) then FOnPositionChange(self, AKind, AValue);
|
|
end;
|
|
|
|
function TMultiSlider.ExtendedThumbs: Boolean;
|
|
begin
|
|
Result := not (FThumbStyle in [tsTriangle, tsTriangleOtherSide]);
|
|
end;
|
|
|
|
function TMultiSlider.GetRectFromPoint(APosition: Integer;
|
|
Alignment: TAlignment): TRect;
|
|
var
|
|
relPos: Double;
|
|
begin
|
|
relPos := (APosition - FRangeMin) / (FRangeMax - FRangeMin);
|
|
if FVertical then begin
|
|
if ExtendedThumbs then
|
|
case Alignment of
|
|
taLeftJustify:
|
|
Result.Top := FTrackStart + Round(FTrackSize.Y * relPos) - FBtnSize.Y;
|
|
taCenter:
|
|
if FSliderMode = smSingle then
|
|
Result.Top := FTrackStart + Round((FTrackSize.Y + FBtnSize.Y) * relPos) - FBtnSize.Y
|
|
else
|
|
Result.Top := FTrackStart + Round((FTrackSize.Y - FBtnSize.Y) * relPos);
|
|
taRightJustify:
|
|
Result.Top := FTrackStart + Round(FTrackSize.Y * relPos);
|
|
end
|
|
else
|
|
Result.Top := FTrackStart + Round(FTrackSize.Y * relPos) - FBtnSize.Y div 2;
|
|
Result.Left := (Width - FBtnSize.X) div 2;
|
|
end else begin
|
|
if ExtendedThumbs then
|
|
case Alignment of
|
|
taLeftJustify:
|
|
Result.Left := FTrackStart + Round(FTrackSize.X * relpos) - FBtnSize.X;
|
|
taCenter:
|
|
if FSliderMode = smSingle then
|
|
Result.Left := FTrackStart + Round((FTrackSize.X + FBtnSize.X) * relPos) - FBtnSize.X
|
|
else
|
|
Result.Left := FTrackStart + Round((FTrackSize.X - FBtnSize.X) * relPos);
|
|
taRightJustify:
|
|
Result.Left := FTrackStart + Round(FTrackSize.X * relPos);
|
|
end
|
|
else
|
|
Result.Left := FTrackStart + Round(FTrackSize.X * relPos) - FBtnSize.X div 2;
|
|
Result.Top := (Height - FBtnSize.Y) div 2;
|
|
end;
|
|
Result.Right := Result.Left + FBtnSize.X;
|
|
Result.Bottom := Result.Top + FBtnSize.Y;
|
|
end;
|
|
|
|
function TMultiSlider.GetThumbCenter(ARect: TRect): TPoint;
|
|
begin
|
|
Result := Point((ARect.Left + ARect.Right) div 2, (ARect.Top + ARect.Bottom) div 2);
|
|
end;
|
|
|
|
function TMultiSlider.GetTrackLength: Integer;
|
|
begin
|
|
if FVertical then
|
|
Result := FTrackSize.Y
|
|
else
|
|
Result := FTrackSize.X;
|
|
end;
|
|
|
|
function TMultiSlider.IsDefaultSizeStored: Boolean;
|
|
begin
|
|
Result := FDefaultSize <> Scale96ToFont(DEFAULT_SIZE);
|
|
end;
|
|
|
|
function TMultiSlider.IsInFirstHalf(APoint: TPoint; ARect: TRect): Boolean;
|
|
begin
|
|
if FVertical then begin
|
|
ARect.Right := GetThumbCenter(ARect).X;
|
|
Result := PtInRect(ARect, APoint);
|
|
end else begin
|
|
ARect.Bottom := GetThumbCenter(ARect).Y;
|
|
Result := PtInRect(ARect, APoint);
|
|
end;
|
|
end;
|
|
|
|
function TMultiSlider.IsTrackThicknessStored: Boolean;
|
|
begin
|
|
Result := FTrackThickness <> Scale96ToFont(DEFAULT_TRACK_THICKNESS);
|
|
end;
|
|
|
|
procedure TMultiSlider.Loaded;
|
|
begin
|
|
inherited;
|
|
exit;
|
|
if FAutoRotate then begin
|
|
if (FVertical and (Width > Height)) or ((not FVertical) and (Width < Height)) then
|
|
SetBounds(Left, Top, Height, Width);
|
|
end;
|
|
end;
|
|
|
|
procedure TMultiSlider.MouseDown(Button: TMouseButton; Shift: TShiftState;
|
|
X,Y: Integer);
|
|
var
|
|
p: TPoint;
|
|
btn1, btn2, btn3: TRect;
|
|
inFirstHalf3: Boolean;
|
|
begin
|
|
if Enabled then begin
|
|
p := Point(x,y);
|
|
btn1 := GetRectFromPoint(FMinPosition, taLeftJustify);
|
|
btn2 := GetRectFromPoint(FMaxPosition, taRightJustify);
|
|
btn3 := GetRectFromPoint(FPosition, taCenter);
|
|
FCapture := -1;
|
|
if (FSliderMode <> smSingle) and PtInRect(btn1, p) then begin
|
|
FCapture := ord(tkMin);
|
|
if ExtendedThumbs then
|
|
FCaptureOffset := IfThen(FVertical, Y - btn1.Bottom, X - btn1.Right)
|
|
else
|
|
FCaptureOffset := IfThen(FVertical, Y - GetThumbCenter(btn1).Y, X - GetThumbCenter(btn1).X);
|
|
end else
|
|
if (FSliderMode <> smSingle) and PtInRect(btn2, p) then begin
|
|
FCapture := ord(tkMax);
|
|
if ExtendedThumbs then
|
|
FCaptureOffset := IfThen(FVertical, Y - btn2.Top, X - btn2.Left)
|
|
else
|
|
FCaptureOffset := IfThen(FVertical, Y - GetThumbCenter(btn2).Y, X - GetThumbCenter(btn2).X)
|
|
end else
|
|
if (FSliderMode <> smMinMax) and PtInRect(btn3, p) then begin
|
|
FCapture := ord(tkValue);
|
|
if ExtendedThumbs then
|
|
FCaptureOffset := IfThen(FVertical, Y - btn3.Top, X - btn3.Left)
|
|
else
|
|
FCaptureOffset := IfThen(FVertical, Y - GetThumbCenter(btn3).Y, X - GetThumbCenter(btn3).X);
|
|
end;
|
|
if (FCapture > -1) and (not ExtendedThumbs and PtInRect(btn3, p)) then begin
|
|
inFirstHalf3 := IsInFirstHalf(p, btn3);
|
|
if (TThumbKind(FCapture) in [tkMin, tkMax]) and (
|
|
(inFirstHalf3 and (FThumbStyle = tsTriangleOtherSide)) or
|
|
((not inFirstHalf3) and (FThumbStyle = tsTriangle))
|
|
) then
|
|
begin
|
|
FCapture := ord(tkValue);
|
|
end;
|
|
end;
|
|
end;
|
|
inherited MouseDown(Button, Shift, X, Y);
|
|
end;
|
|
|
|
procedure TMultiSlider.MouseMove(Shift: TShiftState; X, Y: Integer);
|
|
var
|
|
p: TPoint;
|
|
btn: TRect;
|
|
pos: Integer;
|
|
begin
|
|
if Enabled then begin
|
|
p := Point(X, Y);
|
|
case FCapture of
|
|
-1: begin
|
|
btn := GetRectFromPoint(FMinPosition, taLeftJustify);
|
|
if PtInRect(btn, p) then begin
|
|
Cursor := crHandPoint;
|
|
end else begin
|
|
btn := GetRectFromPoint(FMaxPosition, taRightJustify);
|
|
if PtInRect(btn, p) then begin
|
|
Cursor := crHandPoint;
|
|
end else
|
|
Cursor := crDefault;
|
|
end;
|
|
end;
|
|
else
|
|
pos := PointToPosition(p);
|
|
case TThumbKind(FCapture) of
|
|
tkMin: if FSliderMode <> smSingle then SetMinPosition(pos);
|
|
tkMax: if FSliderMode <> smSingle then SetMaxPosition(pos);
|
|
tkValue: if FSliderMode <> smMinMax then SetPosition(pos);
|
|
end;
|
|
end;
|
|
end;
|
|
inherited MouseMove(Shift,x,y);
|
|
end;
|
|
|
|
procedure TMultiSlider.MouseLeave;
|
|
begin
|
|
inherited MouseLeave;
|
|
FCapture := -1;
|
|
end;
|
|
|
|
procedure TMultiSlider.MouseUp(Button: TMouseButton; Shift: TShiftState;
|
|
X, Y: Integer);
|
|
begin
|
|
FCapture := -1;
|
|
inherited MouseUp(Button,Shift,x,y);
|
|
end;
|
|
|
|
procedure TMultiSlider.Paint;
|
|
|
|
procedure DrawLine(ARect: TRect; AColor, AShadow, AHilight: TColor);
|
|
var
|
|
start, ending, distances, centerpoint, loop: Integer;
|
|
begin
|
|
distances := FDefaultSize div 8;
|
|
start := ARect.Left + FBtnSize.x div 2 - distances*8 div 5;
|
|
ending := start + distances*16 div 5;
|
|
centerPoint := (ARect.Bottom - ARect.Top) div 2 + ARect.Top;
|
|
for loop := -1 to 1 do begin
|
|
Canvas.Pen.Color := AHilight;
|
|
Canvas.MoveTo(start, centerPoint - 1 + loop * distances);
|
|
Canvas.LineTo(ending, centerPoint - 1 + loop * distances);
|
|
|
|
Canvas.Pen.Color := AColor;
|
|
Canvas.MoveTo(start, centerPoint + loop * distances);
|
|
Canvas.LineTo(ending, centerPoint + loop * distances);
|
|
|
|
Canvas.Pen.Color := AShadow;
|
|
Canvas.MoveTo(start, centerPoint + 1 + loop * distances);
|
|
Canvas.LineTo(ending, centerPoint + 1 + loop * distances);
|
|
end;
|
|
end;
|
|
|
|
procedure DrawRect(ARect: TRect; X1,Y1, X2,Y2, R: Integer; AColor: TColor);
|
|
begin
|
|
Canvas.Pen.Color := AColor;
|
|
Canvas.Pen.Width := 1;
|
|
Canvas.Brush.Color := Canvas.Pen.Color;
|
|
Canvas.RoundRect(
|
|
ARect.Left + X1,
|
|
ARect.Top + Y1,
|
|
ARect.Right + X2,
|
|
ARect.Bottom + Y2,
|
|
R, R);
|
|
end;
|
|
|
|
procedure DrawThumb(ARect, ATrackRect: TRect; InFirstHalf: Boolean);
|
|
var
|
|
radius: Integer;
|
|
center: TPoint;
|
|
P: array[0..2] of TPoint;
|
|
begin
|
|
case FThumbStyle of
|
|
tsGrip, tsRoundedRect:
|
|
begin
|
|
radius := Min(FBtnSize.X, FBtnSize.Y) div 2;
|
|
if FFlat then
|
|
DrawRect(ARect, 0, 0, 0, 0, radius, FColorThumb)
|
|
else begin
|
|
DrawRect(ARect, 0, 0, -1, -1, radius, clBtnHighlight);
|
|
DrawRect(ARect, 1, 1, 0, 0, radius, clBtnShadow);
|
|
DrawRect(ARect, 1, 1, -1, -1, radius, FColorThumb);
|
|
end;
|
|
if FThumbStyle = tsGrip then
|
|
DrawLine(ARect, FColorThumb, clBtnShadow, clBtnHighlight);
|
|
end;
|
|
tsCircle:
|
|
begin
|
|
center := Point((ARect.Left + ARect.Right) div 2, (ARect.Top + ARect.Bottom) div 2);
|
|
radius := Min(ARect.Right - ARect.Left, ARect.Bottom - ARect.Top) div 2;
|
|
if not FFlat then begin
|
|
Canvas.Brush.Style := bsClear;
|
|
Canvas.Pen.Color := clBtnHighlight;
|
|
Canvas.Ellipse(center.X - radius - 1, center.Y - radius - 1, center.X + radius - 1, center.Y + radius - 1);
|
|
Canvas.Pen.Color := clBtnShadow;
|
|
Canvas.Ellipse(center.X - radius + 1, center.Y - radius + 1, center.X + radius + 1, center.Y + radius + 1);
|
|
end;
|
|
Canvas.Brush.Style := bsSolid;
|
|
Canvas.Brush.Color := FColorThumb;
|
|
Canvas.Pen.Color := FColorThumb;
|
|
Canvas.Ellipse(center.X - radius, center.Y - radius, center.X + radius, center.Y + radius);
|
|
end;
|
|
tsRect:
|
|
begin
|
|
if not FFlat then begin
|
|
Canvas.Brush.Style := bsClear;
|
|
Canvas.Pen.Color := clBtnHighlight;
|
|
Canvas.Rectangle(ARect.Left - 1, ARect.Top - 1, ARect.Right - 1, ARect.Bottom - 1);
|
|
Canvas.Pen.Color := clBtnShadow;
|
|
Canvas.Rectangle(ARect.Left + 1, ARect.Top + 1, ARect.Right + 1, ARect.Bottom + 1);
|
|
end;
|
|
Canvas.Brush.Style := bsSolid;
|
|
Canvas.Brush.Color := FColorThumb;
|
|
Canvas.Pen.Color := FColorThumb;
|
|
Canvas.Rectangle(ARect);
|
|
end;
|
|
tsTriangle, tsTriangleOtherSide:
|
|
begin
|
|
if FVertical then begin
|
|
if InFirstHalf then begin
|
|
P[0] := Point(ARect.Left, ARect.Top);
|
|
P[1] := Point(ARect.Left, ARect.Bottom);
|
|
P[2] := Point(ATrackRect.Left, GetThumbCenter(ARect).Y);
|
|
end else begin
|
|
P[0] := Point(ARect.Right, ARect.Top);
|
|
P[1] := Point(ARect.Right, ARect.Bottom);
|
|
P[2] := Point(ATrackRect.Right, GetThumbCenter(ARect).Y);
|
|
end;
|
|
end else begin
|
|
if InFirstHalf then begin
|
|
P[0] := Point(ARect.Left, ARect.Bottom);
|
|
P[1] := Point(ARect.Right, ARect.Bottom);
|
|
P[2] := Point(GetThumbCenter(ARect).X, ATrackRect.Bottom);
|
|
end else begin
|
|
P[0] := Point(ARect.Left, ARect.Top);
|
|
P[1] := Point(ARect.Right, ARect.Top);
|
|
P[2] := Point(GetThumbCenter(ARect).X, ATrackRect.Top);
|
|
end;
|
|
end;
|
|
if not FFlat then begin
|
|
Canvas.Brush.Style := bsClear;
|
|
Canvas.Pen.Color := clBtnHighlight;
|
|
Canvas.Polygon([Point(P[0].X-1, P[0].Y-1), Point(P[1].X-1, P[1].Y-1), Point(P[2].X-1, P[2].Y-1)]);
|
|
Canvas.Pen.Color := clBtnShadow;
|
|
Canvas.Polygon([Point(P[0].X+1, P[0].Y+1), Point(P[1].X+1, P[1].Y+1), Point(P[2].X+1, P[2].Y+1)]);
|
|
end;
|
|
Canvas.Brush.Style := bsSolid;
|
|
Canvas.Brush.Color := FColorThumb;
|
|
Canvas.Pen.Color := FColorThumb;
|
|
Canvas.Polygon(P);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
R: Integer;
|
|
track, rang, btn1, btn2, btn: TRect;
|
|
rectBelow, rectAbove: TRect;
|
|
dx, dy: Integer;
|
|
begin
|
|
if FVertical then begin
|
|
track.Left := (Width - FTrackSize.X) div 2;
|
|
track.Top := FTrackStart;
|
|
end else begin
|
|
track.Left := FTrackStart;
|
|
track.Top := (Height - FTrackSize.Y) div 2;
|
|
end;
|
|
track.Right := track.Left + FTrackSize.x;
|
|
track.Bottom := track.Top + FTrackSize.y;
|
|
|
|
btn1 := GetRectFromPoint(FMinPosition, taLeftJustify);
|
|
btn2 := GetRectFromPoint(FMaxPosition, taRightJustify);
|
|
btn := GetRectFromPoint(FPosition, taCenter);
|
|
|
|
if FVertical then begin
|
|
dx := 0;
|
|
dy := IfThen(ExtendedThumbs, FBtnSize.Y, 0);
|
|
rang.Top := IfThen(ExtendedThumbs, btn1.Bottom, GetThumbCenter(btn1).Y);
|
|
rang.Bottom := IfThen(ExtendedThumbs, btn2.Top, GetThumbCenter(btn2).Y);
|
|
rang.Left := track.Left;
|
|
rang.Right := track.Right;
|
|
if FSliderMode = smSingle then begin
|
|
rectBelow := Rect(track.Left, track.Top, track.Right, IfThen(ExtendedThumbs, btn.Top, GetThumbCenter(btn).Y));
|
|
rectAbove := Rect(track.Left, IfThen(ExtendedThumbs, btn.Bottom, GetThumbCenter(btn).Y), track.Right, track.bottom);
|
|
end else begin
|
|
rectBelow := Rect(track.Left, track.Top, track.Right, rang.Top);
|
|
rectAbove := Rect(track.Left, rang.Bottom, track.Right, track.Bottom);
|
|
end;
|
|
end else begin
|
|
dx := IfThen(ExtendedThumbs, FBtnSize.X, 0);
|
|
dy := 0;
|
|
rang.Top := track.Top;
|
|
rang.Bottom := track.Bottom;
|
|
rang.Left := IfThen(ExtendedThumbs, btn1.Right, GetThumbCenter(btn1).X);
|
|
rang.Right := IfThen(ExtendedThumbs, btn2.Left, GetThumbCenter(btn2).X);
|
|
if FSliderMode = smSingle then begin
|
|
rectBelow := Rect(track.Left, track.Top, IfThen(ExtendedThumbs, btn.Left, GetThumbCenter(btn).X), track.Bottom);
|
|
rectAbove := Rect(IfThen(ExtendedThumbs, btn.Right, GetThumbCenter(btn).X), track.Top, track.Right, track.Bottom);
|
|
end else begin
|
|
rectBelow := Rect(track.Left, track.Top, rang.Left, track.Bottom);
|
|
rectAbove := Rect(rang.Right, track.Top, track.Right, track.Bottom)
|
|
end;
|
|
end;
|
|
|
|
R := IfThen(ExtendedThumbs, Min(FTrackSize.X, FTrackSize.Y), 0);
|
|
if not Flat then begin
|
|
DrawRect(track, -(dx+2), -(dy+2), dx, dy, R, clBtnShadow);
|
|
DrawRect(track, -dx, -dy, dx+2, dy+2, R, clBtnHighlight);
|
|
end;
|
|
DrawRect(rectBelow, -(dx+1), -(dy+1), dx+1, dy+1, R, FColorBelow);
|
|
DrawRect(rectAbove, -(dx+1), -(dy+1), dx+1, dy+1, R, FColorAbove);
|
|
if FSliderMode <> smSingle then
|
|
DrawRect(rang, -1, -1, 1, 1, 0, FColorBetween);
|
|
|
|
if (FSliderMode <> smSingle) then begin
|
|
DrawThumb(btn1, track, FThumbStyle = tsTriangleOtherSide);
|
|
DrawThumb(btn2, track, FThumbStyle = tsTriangleOtherSide);
|
|
end;
|
|
if (FSliderMode <> smMinMax) then
|
|
DrawThumb(btn, track, FThumbStyle <> tsTriangleOtherSide);
|
|
end;
|
|
|
|
function TMultiSlider.PointToPosition(P: TPoint): Integer;
|
|
var
|
|
pos_start, pos_range: Integer;
|
|
coord: Integer;
|
|
coord_range: Integer;
|
|
coord_start: Integer;
|
|
btn1, btn2: TRect;
|
|
begin
|
|
if FVertical then
|
|
coord := P.Y
|
|
else
|
|
coord := P.X;
|
|
if (TThumbKind(FCapture) = tkValue) and (FSliderMode <> smSingle) then begin
|
|
btn1 := GetRectFromPoint(FMinPosition, taLeftJustify);
|
|
btn2 := GetRectFromPoint(FMaxPosition, taRightJustify);
|
|
pos_start := FMinPosition;
|
|
pos_range := FMaxPosition - FMinPosition;
|
|
if ExtendedThumbs then begin
|
|
if FVertical then begin
|
|
coord_start := btn1.Bottom + FCaptureOffset;
|
|
coord_range := btn2.Top - btn1.Bottom;
|
|
end else begin
|
|
coord_start := btn1.Right + FCaptureOffset;
|
|
coord_range := btn2.Left - btn1.Right;
|
|
end;
|
|
end else begin
|
|
if FVertical then begin
|
|
coord_start := GetThumbCenter(btn1).Y + FCaptureOffset;
|
|
coord_range := btn2.Top - btn1.Top;
|
|
end else begin
|
|
coord_start := GetThumbCenter(btn1).X + FCaptureOffset;
|
|
coord_range := btn2.Left - btn1.Left;
|
|
end;
|
|
end;
|
|
{
|
|
if FThumbStyle = tsTriangle then begin
|
|
if FVertical then begin
|
|
end else begin
|
|
coord_start := (btn1.Left + btn1.Right) div 2 + FCaptureOffset;
|
|
coord_range := btn2.Left - btn1.Left;
|
|
end
|
|
end else begin
|
|
if FVertical then begin
|
|
coord_start := btn1.Top + FCaptureOffset;
|
|
coord_range := btn2.Top - btn1.Bottom;
|
|
end else begin
|
|
coord_start := btn1.Right + FCaptureOffset;
|
|
coord_range := btn2.Left - btn1.Right;
|
|
end;
|
|
end;
|
|
}
|
|
end else begin
|
|
pos_start := FRangeMin;
|
|
pos_range := FRangeMax - FRangeMin;
|
|
coord_start := FTrackStart + FCaptureOffset;
|
|
coord_range := GetTracklength;
|
|
end;
|
|
Result := round(pos_start + pos_range * (coord - coord_start) / coord_range);
|
|
end;
|
|
|
|
procedure TMultiSlider.Resize;
|
|
begin
|
|
inherited;
|
|
UpdateBounds;
|
|
end;
|
|
{
|
|
procedure TMultiSlider.SetColor(AValue: TColor);
|
|
begin
|
|
inherited;
|
|
if AValue = clNone then
|
|
ControlStyle := ControlStyle - [csOpaque]
|
|
else
|
|
ControlStyle := ControlStyle + [csOpaque];
|
|
end; }
|
|
|
|
procedure TMultiSlider.SetColorAbove(AValue: TColor);
|
|
begin
|
|
if AValue = FColorAbove then exit;
|
|
FColorAbove := AValue;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetColorBelow(AValue: TColor);
|
|
begin
|
|
if AValue = FColorBelow then exit;
|
|
FColorBelow := AValue;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetColorBetween(AValue: TColor);
|
|
begin
|
|
if AValue = FColorBetween then exit;
|
|
FColorBetween := AValue;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetColorThumb(AValue: TColor);
|
|
begin
|
|
if AValue = FColorThumb then exit;
|
|
FColorThumb := AValue;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetDefaultSize(AValue: Integer);
|
|
begin
|
|
if FDefaultSize = AValue then exit;
|
|
FDefaultSize := AValue;
|
|
if AutoSize then begin
|
|
if FVertical then Width := FDefaultSize else Height := FDefaultSize;
|
|
end;
|
|
UpdateBounds;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetFlat(AValue: Boolean);
|
|
begin
|
|
if FFlat = AValue then exit;
|
|
FFlat := AValue;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetMaxPosition(AValue: Integer);
|
|
var
|
|
newPos: Integer;
|
|
begin
|
|
newPos := Min(Max(AValue, FRangeMin), FRangeMax);
|
|
if (newPos = FMaxPosition) then exit;
|
|
if (newPos < FMinPosition) and (FSliderMode <> smSingle) then newPos := FMinPosition;
|
|
if (newPos < FPosition) and (FSliderMode <> smMinMax) then newPos := FPosition;
|
|
FMaxPosition := newPos;
|
|
DoPositionChange(tkMax, FMaxPosition);
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetMinPosition(AValue: Integer);
|
|
var
|
|
newPos: Integer;
|
|
begin
|
|
newPos := Max(Min(AValue, FRangeMax), FRangeMin);
|
|
if (newPos = FMinPosition) then exit;
|
|
if (newPos > FMaxPosition) and (FSliderMode <> smSingle) then newPos := FMaxPosition;
|
|
if (newPos > FPosition) and (FSliderMode <> smMinMax) then newPos := FPosition;
|
|
FMinPosition := newPos;
|
|
DoPositionChange(tkMin, FMinPosition);
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetPosition(AValue: Integer);
|
|
var
|
|
newPos: Integer;
|
|
begin
|
|
newPos := Max(Min(AValue, FRangeMax), FRangeMin);
|
|
if (newPos = FPosition) then exit;
|
|
if (FSliderMode <> smSingle) then begin
|
|
if (newPos < FMinPosition) then newPos := FMinPosition;
|
|
if (newPos > FMaxPosition) then newPos := FMaxPosition;
|
|
end;
|
|
FPosition := newPos;
|
|
DoPositionChange(tkValue, FPosition);
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetRangeMax(AValue:Integer);
|
|
begin
|
|
if FRangeMax = AValue then exit;
|
|
FRangeMax := AValue;
|
|
DoPositionChange(tkMax, FRangeMax);
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetRangeMin(AValue: Integer);
|
|
begin
|
|
if FRangeMin = AValue then exit;
|
|
FRangeMin := AValue;
|
|
DoPositionChange(tkMin, FRangeMin);
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetThumbStyle(AValue: TThumbStyle);
|
|
begin
|
|
if FThumbStyle = AValue then exit;
|
|
FThumbStyle := AValue;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetTrackThickness(AValue: Integer);
|
|
begin
|
|
if FTrackThickness = AValue then exit;
|
|
FTrackThickness := AValue;
|
|
UpdateBounds;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetVertical(AValue: Boolean);
|
|
begin
|
|
if FVertical = AValue then exit;
|
|
FVertical := AValue;
|
|
//if not (csLoading in ComponentState) then begin
|
|
if FAutoRotate then begin
|
|
if (FVertical and (Width > Height)) or ((not FVertical) and (Width < Height)) then
|
|
SetBounds(Left, Top, Height, Width);
|
|
end;
|
|
UpdateBounds;
|
|
//end;
|
|
end;
|
|
|
|
procedure TMultiSlider.SetSliderMode(AValue: TSliderMode);
|
|
begin
|
|
if FSliderMode = AValue then exit;
|
|
FSliderMode := AValue;
|
|
Invalidate;
|
|
end;
|
|
|
|
procedure TMultiSlider.UpdateBounds;
|
|
var
|
|
buttonSize: Integer;
|
|
begin
|
|
buttonSize := FDefaultSize*5 div 8;
|
|
if FVertical then begin
|
|
FBtnSize := Point(FDefaultSize, buttonSize);
|
|
FTrackSize := Point(FTrackThickness, Height - FTrackStart * 2);
|
|
end else begin
|
|
FBtnSize:= Point(buttonSize, FDefaultSize);
|
|
FTrackSize := Point(Width - FTrackStart * 2, FTrackThickness);
|
|
end;
|
|
Invalidate;
|
|
end;
|
|
|
|
end.
|
|
|
|
|