You've already forked lazarus-ccr
industrial: Add MultiSlider component.
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6850 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
218
components/industrialstuff/Example/MultiSliderSample/main.lfm
Normal file
218
components/industrialstuff/Example/MultiSliderSample/main.lfm
Normal file
@ -0,0 +1,218 @@
|
||||
object Form1: TForm1
|
||||
Left = 326
|
||||
Height = 396
|
||||
Top = 127
|
||||
Width = 528
|
||||
Caption = 'Form1'
|
||||
ClientHeight = 396
|
||||
ClientWidth = 528
|
||||
OnCreate = FormCreate
|
||||
LCLVersion = '2.1.0.0'
|
||||
object cbVertical: TCheckBox
|
||||
Left = 110
|
||||
Height = 19
|
||||
Top = 154
|
||||
Width = 59
|
||||
Caption = 'Vertical'
|
||||
OnChange = cbVerticalChange
|
||||
TabOrder = 0
|
||||
end
|
||||
object cbAutoRotate: TCheckBox
|
||||
Left = 110
|
||||
Height = 19
|
||||
Top = 177
|
||||
Width = 80
|
||||
Caption = 'AutoRotate'
|
||||
Checked = True
|
||||
OnChange = cbAutoRotateChange
|
||||
State = cbChecked
|
||||
TabOrder = 1
|
||||
end
|
||||
object Label1: TLabel
|
||||
Left = 104
|
||||
Height = 15
|
||||
Top = 64
|
||||
Width = 47
|
||||
Caption = 'Min = 20'
|
||||
ParentColor = False
|
||||
end
|
||||
object Label2: TLabel
|
||||
Left = 176
|
||||
Height = 15
|
||||
Top = 64
|
||||
Width = 54
|
||||
Caption = 'Value = 50'
|
||||
ParentColor = False
|
||||
end
|
||||
object Label3: TLabel
|
||||
Left = 252
|
||||
Height = 15
|
||||
Top = 64
|
||||
Width = 48
|
||||
Caption = 'Max = 80'
|
||||
ParentColor = False
|
||||
end
|
||||
object cbColorBelow: TColorButton
|
||||
Left = 104
|
||||
Height = 25
|
||||
Top = 82
|
||||
Width = 56
|
||||
BorderWidth = 2
|
||||
ButtonColorSize = 16
|
||||
ButtonColor = clBlack
|
||||
OnColorChanged = cbColorBelowColorChanged
|
||||
end
|
||||
object cbColorBetween: TColorButton
|
||||
Left = 174
|
||||
Height = 25
|
||||
Top = 82
|
||||
Width = 56
|
||||
BorderWidth = 2
|
||||
ButtonColorSize = 16
|
||||
ButtonColor = clBlack
|
||||
OnColorChanged = cbColorBetweenColorChanged
|
||||
end
|
||||
object cbColorAbove: TColorButton
|
||||
Left = 248
|
||||
Height = 25
|
||||
Top = 82
|
||||
Width = 56
|
||||
BorderWidth = 2
|
||||
ButtonColorSize = 16
|
||||
ButtonColor = clBlack
|
||||
OnColorChanged = cbColorAboveColorChanged
|
||||
end
|
||||
object cbFormColor: TColorButton
|
||||
Left = 328
|
||||
Height = 25
|
||||
Top = 82
|
||||
Width = 120
|
||||
BorderWidth = 2
|
||||
ButtonColorSize = 16
|
||||
ButtonColor = clBlack
|
||||
Caption = 'Form'
|
||||
OnColorChanged = cbFormColorColorChanged
|
||||
end
|
||||
object cmbThumbStyle: TComboBox
|
||||
Left = 110
|
||||
Height = 23
|
||||
Top = 203
|
||||
Width = 132
|
||||
ItemHeight = 15
|
||||
ItemIndex = 0
|
||||
Items.Strings = (
|
||||
'Grip'
|
||||
'Circle'
|
||||
'Rectangle'
|
||||
'Rounded Rectangle'
|
||||
'Triangles'
|
||||
'Triangles (on other side)'
|
||||
)
|
||||
OnChange = cmbThumbStyleChange
|
||||
Style = csDropDownList
|
||||
TabOrder = 2
|
||||
Text = 'Grip'
|
||||
end
|
||||
object cbColorThumb: TColorButton
|
||||
Left = 328
|
||||
Height = 25
|
||||
Top = 112
|
||||
Width = 120
|
||||
BorderWidth = 2
|
||||
ButtonColorSize = 16
|
||||
ButtonColor = clBlack
|
||||
Caption = 'Thumb'
|
||||
OnColorChanged = cbColorThumbColorChanged
|
||||
end
|
||||
object cbFlat: TCheckBox
|
||||
Left = 200
|
||||
Height = 19
|
||||
Top = 154
|
||||
Width = 39
|
||||
Caption = 'Flat'
|
||||
OnChange = cbFlatChange
|
||||
TabOrder = 3
|
||||
end
|
||||
object seTrackThickness: TSpinEdit
|
||||
Left = 280
|
||||
Height = 23
|
||||
Top = 203
|
||||
Width = 82
|
||||
OnChange = seTrackThicknessChange
|
||||
TabOrder = 4
|
||||
end
|
||||
object Label4: TLabel
|
||||
Left = 280
|
||||
Height = 15
|
||||
Top = 181
|
||||
Width = 80
|
||||
Caption = 'Track thickness'
|
||||
ParentColor = False
|
||||
end
|
||||
object Label5: TLabel
|
||||
Left = 376
|
||||
Height = 15
|
||||
Top = 181
|
||||
Width = 60
|
||||
Caption = 'Default size'
|
||||
ParentColor = False
|
||||
end
|
||||
object seDefaultSize: TSpinEdit
|
||||
Left = 376
|
||||
Height = 23
|
||||
Top = 203
|
||||
Width = 82
|
||||
OnChange = seDefaultSizeChange
|
||||
TabOrder = 5
|
||||
end
|
||||
object cbEnabled: TCheckBox
|
||||
Left = 110
|
||||
Height = 19
|
||||
Top = 128
|
||||
Width = 62
|
||||
Caption = 'Enabled'
|
||||
Checked = True
|
||||
OnChange = cbEnabledChange
|
||||
State = cbChecked
|
||||
TabOrder = 6
|
||||
end
|
||||
object cbSliderColor: TColorButton
|
||||
Left = 328
|
||||
Height = 25
|
||||
Top = 140
|
||||
Width = 120
|
||||
BorderWidth = 2
|
||||
ButtonColorSize = 16
|
||||
ButtonColor = clBlack
|
||||
Caption = 'Control'
|
||||
OnColorChanged = cbSliderColorColorChanged
|
||||
end
|
||||
object cbTransparent: TCheckBox
|
||||
Left = 200
|
||||
Height = 19
|
||||
Top = 128
|
||||
Width = 83
|
||||
Caption = 'Transparent'
|
||||
Checked = True
|
||||
OnChange = cbTransparentChange
|
||||
State = cbChecked
|
||||
TabOrder = 7
|
||||
end
|
||||
object cmbSliderMode: TComboBox
|
||||
Left = 110
|
||||
Height = 23
|
||||
Top = 235
|
||||
Width = 132
|
||||
ItemHeight = 15
|
||||
ItemIndex = 0
|
||||
Items.Strings = (
|
||||
'single'
|
||||
'min ... max'
|
||||
'min ... value ... max'
|
||||
)
|
||||
OnChange = cmbSliderModeChange
|
||||
Style = csDropDownList
|
||||
TabOrder = 8
|
||||
Text = 'single'
|
||||
end
|
||||
end
|
||||
180
components/industrialstuff/Example/MultiSliderSample/main.pas
Normal file
180
components/industrialstuff/Example/MultiSliderSample/main.pas
Normal file
@ -0,0 +1,180 @@
|
||||
unit main;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ColorBox,
|
||||
Spin, ExtCtrls, switches, indSliders;
|
||||
|
||||
type
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
TForm1 = class(TForm)
|
||||
cbSliderColor: TColorButton;
|
||||
cbVertical: TCheckBox;
|
||||
cbAutoRotate: TCheckBox;
|
||||
cbColorBelow: TColorButton;
|
||||
cbColorBetween: TColorButton;
|
||||
cbColorAbove: TColorButton;
|
||||
cbFlat: TCheckBox;
|
||||
cbEnabled: TCheckBox;
|
||||
cbTransparent: TCheckBox;
|
||||
cbFormColor: TColorButton;
|
||||
cmbThumbStyle: TComboBox;
|
||||
cbColorThumb: TColorButton;
|
||||
cmbSliderMode: TComboBox;
|
||||
Label1: TLabel;
|
||||
Label2: TLabel;
|
||||
Label3: TLabel;
|
||||
Label4: TLabel;
|
||||
Label5: TLabel;
|
||||
seTrackThickness: TSpinEdit;
|
||||
seDefaultSize: TSpinEdit;
|
||||
procedure cbAutoRotateChange(Sender: TObject);
|
||||
procedure cbColorAboveColorChanged(Sender: TObject);
|
||||
procedure cbColorBelowColorChanged(Sender: TObject);
|
||||
procedure cbColorBetweenColorChanged(Sender: TObject);
|
||||
procedure cbColorThumbColorChanged(Sender: TObject);
|
||||
procedure cbEnabledChange(Sender: TObject);
|
||||
procedure cbFlatChange(Sender: TObject);
|
||||
procedure cbSliderColorColorChanged(Sender: TObject);
|
||||
procedure cmbSliderModeChange(Sender: TObject);
|
||||
procedure cmbThumbStyleChange(Sender: TObject);
|
||||
procedure cbTransparentChange(Sender: TObject);
|
||||
procedure cbVerticalChange(Sender: TObject);
|
||||
procedure cbFormColorColorChanged(Sender: TObject);
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure seDefaultSizeChange(Sender: TObject);
|
||||
procedure seTrackThicknessChange(Sender: TObject);
|
||||
private
|
||||
slider: TMultiSlider;
|
||||
procedure PositionChangeHandler(Sender: TObject; AKind: TThumbKind; AValue: Integer);
|
||||
|
||||
public
|
||||
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.lfm}
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
begin
|
||||
slider := TMultiSlider.Create(self);
|
||||
slider.Parent := self;
|
||||
slider.Align := alTop;
|
||||
slider.BorderSpacing.Around := 8;
|
||||
// slider.Left := 8;
|
||||
// slider.Top := 8;
|
||||
slider.Vertical := false;
|
||||
slider.OnPositionChange := @PositionChangeHandler;
|
||||
|
||||
cbColorBelow.ButtonColor := slider.ColorBelow;
|
||||
cbColorAbove.ButtonColor := slider.ColorAbove;
|
||||
cbColorBetween.ButtonColor := slider.ColorBetween;
|
||||
cbColorThumb.ButtonColor := slider.ColorThumb;
|
||||
cbSliderColor.ButtonColor := slider.Color;
|
||||
cbFormColor.ButtonColor := Color;
|
||||
cbTransparent.Checked := slider.Color = clNone;
|
||||
seTrackThickness.Value := slider.TrackThickness;
|
||||
seDefaultSize.Value := slider.DefaultSize;
|
||||
cmbSliderMode.ItemIndex := ord(slider.SliderMode);
|
||||
end;
|
||||
|
||||
procedure TForm1.seDefaultSizeChange(Sender: TObject);
|
||||
begin
|
||||
slider.DefaultSize := seDefaultSize.Value;
|
||||
end;
|
||||
|
||||
procedure TForm1.seTrackThicknessChange(Sender: TObject);
|
||||
begin
|
||||
slider.TrackThickness := seTrackThickness.Value;
|
||||
end;
|
||||
|
||||
procedure TForm1.cbVerticalChange(Sender: TObject);
|
||||
begin
|
||||
slider.Vertical := cbVertical.Checked;
|
||||
if slider.Vertical then slider.Align := alLeft else slider.Align := alTop;
|
||||
end;
|
||||
|
||||
procedure TForm1.cbFormColorColorChanged(Sender: TObject);
|
||||
begin
|
||||
Color := cbFormColor.ButtonColor;
|
||||
end;
|
||||
|
||||
procedure TForm1.cbColorThumbColorChanged(Sender: TObject);
|
||||
begin
|
||||
slider.ColorThumb := cbColorThumb.ButtonColor;
|
||||
end;
|
||||
|
||||
procedure TForm1.cbAutoRotateChange(Sender: TObject);
|
||||
begin
|
||||
slider.AutoRotate := cbAutoRotate.Checked;
|
||||
end;
|
||||
|
||||
procedure TForm1.cbColorAboveColorChanged(Sender: TObject);
|
||||
begin
|
||||
slider.ColorAbove := cbColorAbove.ButtonColor;
|
||||
end;
|
||||
|
||||
procedure TForm1.cbColorBelowColorChanged(Sender: TObject);
|
||||
begin
|
||||
slider.ColorBelow := cbColorBelow.ButtonColor;
|
||||
end;
|
||||
|
||||
procedure TForm1.cbColorBetweenColorChanged(Sender: TObject);
|
||||
begin
|
||||
slider.ColorBetween := cbColorBetween.ButtonColor;
|
||||
end;
|
||||
|
||||
procedure TForm1.cbSliderColorColorChanged(Sender: TObject);
|
||||
begin
|
||||
slider.Color := cbSliderColor.ButtonColor;
|
||||
end;
|
||||
|
||||
procedure TForm1.cmbSliderModeChange(Sender: TObject);
|
||||
begin
|
||||
slider.SliderMode := TSliderMode(cmbSliderMode.ItemIndex);
|
||||
end;
|
||||
|
||||
procedure TForm1.cbEnabledChange(Sender: TObject);
|
||||
begin
|
||||
slider.Enabled := cbEnabled.Checked;
|
||||
end;
|
||||
|
||||
procedure TForm1.cbFlatChange(Sender: TObject);
|
||||
begin
|
||||
slider.Flat := cbFlat.Checked;
|
||||
end;
|
||||
|
||||
procedure TForm1.cmbThumbStyleChange(Sender: TObject);
|
||||
begin
|
||||
slider.ThumbStyle := TThumbStyle(cmbThumbStyle.ItemIndex);
|
||||
end;
|
||||
|
||||
procedure TForm1.cbTransparentChange(Sender: TObject);
|
||||
begin
|
||||
if cbTransparent.Checked then
|
||||
slider.Color := clNone;
|
||||
end;
|
||||
|
||||
procedure TForm1.PositionChangeHandler(Sender: TObject; AKind: TThumbKind;
|
||||
AValue: Integer);
|
||||
begin
|
||||
case AKind of
|
||||
tkMin: Label1.Caption := 'Min = ' + intToStr(AValue);
|
||||
tkValue: Label2.Caption := 'Value = ' + IntToStr(AValue);
|
||||
tkMax: Label3.Caption := 'Max = ' + IntToStr(AValue);
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
@ -0,0 +1,77 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="12"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<CompatibilityMode Value="True"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<Title Value="sliderdemo"/>
|
||||
<Scaled Value="True"/>
|
||||
<ResourceType Value="res"/>
|
||||
<UseXPManifest Value="True"/>
|
||||
<XPManifest>
|
||||
<DpiAware Value="True"/>
|
||||
</XPManifest>
|
||||
<Icon Value="0"/>
|
||||
</General>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<UseFileFilters Value="True"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<FormatVersion Value="2"/>
|
||||
<Modes Count="0"/>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="2">
|
||||
<Item1>
|
||||
<PackageName Value="industrial"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item2>
|
||||
</RequiredPackages>
|
||||
<Units Count="2">
|
||||
<Unit0>
|
||||
<Filename Value="sliderdemo.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="main.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ComponentName Value="Form1"/>
|
||||
<HasResources Value="True"/>
|
||||
<ResourceBaseClass Value="Form"/>
|
||||
</Unit1>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="sliderdemo"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
@ -0,0 +1,22 @@
|
||||
program sliderdemo;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
{$IFDEF UNIX}{$IFDEF UseCThreads}
|
||||
cthreads,
|
||||
{$ENDIF}{$ENDIF}
|
||||
Interfaces, // this includes the LCL widgetset
|
||||
Forms, main
|
||||
{ you can add units after this };
|
||||
|
||||
{$R *.res}
|
||||
|
||||
begin
|
||||
RequireDerivedFormResource:=True;
|
||||
Application.Scaled:=True;
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
@ -33,10 +33,11 @@
|
||||
- analog gauges
|
||||
- thermometer-like gauge
|
||||
- knob
|
||||
- on/off switch"/>
|
||||
- on/off switch
|
||||
- multislider"/>
|
||||
<License Value="MPL + GPL + modified LGPL (see unit headers)."/>
|
||||
<Version Minor="3"/>
|
||||
<Files Count="13">
|
||||
<Version Minor="4"/>
|
||||
<Files Count="14">
|
||||
<Item1>
|
||||
<Filename Value="source\indled.pas"/>
|
||||
<UnitName Value="IndLed"/>
|
||||
@ -90,7 +91,12 @@
|
||||
<Filename Value="source\switches.pas"/>
|
||||
<UnitName Value="switches"/>
|
||||
</Item13>
|
||||
<Item14>
|
||||
<Filename Value="source\indsliders.pas"/>
|
||||
<UnitName Value="indsliders"/>
|
||||
</Item14>
|
||||
</Files>
|
||||
<LazDoc Paths="D:\Prog_Lazarus\svn\lazarus-ccr\components\industrialstuff\fpdoc"/>
|
||||
<RequiredPkgs Count="1">
|
||||
<Item1>
|
||||
<PackageName Value="IDEIntf"/>
|
||||
|
||||
@ -10,7 +10,7 @@ interface
|
||||
uses
|
||||
IndLed, Sensors, AllIndustrialRegister, LedNumber, indGnouMeter, AdvLed,
|
||||
indcyBaseLed, indcyClasses, indcyGraphics, indcyTypes, A3nalogGauge, MKnob,
|
||||
switches, LazarusPackageIntf;
|
||||
switches, indSliders, LazarusPackageIntf;
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
@ -13,3 +13,6 @@ tmknob_200.png
|
||||
tonoffswitch.png
|
||||
tonoffswitch_150.png
|
||||
tonoffswitch_200.png
|
||||
tmultislider.png
|
||||
tmultislider_150.png
|
||||
tmultislider_200.png
|
||||
|
||||
BIN
components/industrialstuff/resources/tmultislider.png
Normal file
BIN
components/industrialstuff/resources/tmultislider.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 534 B |
BIN
components/industrialstuff/resources/tmultislider_150.png
Normal file
BIN
components/industrialstuff/resources/tmultislider_150.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 778 B |
BIN
components/industrialstuff/resources/tmultislider_200.png
Normal file
BIN
components/industrialstuff/resources/tmultislider_200.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 935 B |
@ -12,7 +12,7 @@ interface
|
||||
|
||||
uses
|
||||
Classes, LResources, AdvLed, IndLed, LedNumber, Sensors, IndGnouMeter,
|
||||
A3nalogGauge, MKnob, Switches;
|
||||
A3nalogGauge, MKnob, Switches, indSliders;
|
||||
|
||||
procedure Register;
|
||||
|
||||
@ -25,7 +25,8 @@ procedure Register;
|
||||
begin
|
||||
RegisterComponents ('Industrial',[
|
||||
TAdvLed, TIndLed, TLedNumber, TStopLightSensor,
|
||||
TAnalogSensor, TA3nalogGauge, TindGnouMeter, TmKnob, TOnOffSwitch
|
||||
TAnalogSensor, TA3nalogGauge, TindGnouMeter,
|
||||
TmKnob, TOnOffSwitch, TMultiSlider
|
||||
]);
|
||||
|
||||
end;
|
||||
|
||||
853
components/industrialstuff/source/indsliders.pas
Normal file
853
components/industrialstuff/source/indsliders.pas
Normal file
@ -0,0 +1,853 @@
|
||||
{
|
||||
/***************************************************************************
|
||||
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.
|
||||
|
||||
|
||||
Binary file not shown.
@ -52,7 +52,7 @@ uses
|
||||
Controls, Forms, Dialogs, ComCtrls;
|
||||
|
||||
const
|
||||
DEFAULT_KNOB_FACE_COLOR = clSilver; //$00B5CCBD;
|
||||
DEFAULT_KNOB_FACE_COLOR = clSilver;
|
||||
DEFAULT_KNOB_MARK_SIZE = 6;
|
||||
|
||||
type
|
||||
|
||||
Reference in New Issue
Block a user