### Bookstore

 Computer Math and Games in Pascal (preview) Lazarus Handbook

### Author Topic: Slider with 2 Knobs  (Read 2719 times)

#### apeoperaio

• Full Member
• Posts: 198
##### Slider with 2 Knobs
« on: April 16, 2019, 11:07:39 am »
Dear all,
anyone knows if there is a lazarus component that is a Slider with two knobs?

Or the attached image
Thanks,
Andrea

#### bylaardt

• Sr. Member
• Posts: 308
##### Re: Slider with 2 Knobs
« Reply #1 on: April 19, 2019, 05:32:51 am »
challenge accepted! so I did it from scratch!
Code: Pascal  [Select][+][-]
1. unit pb_slider;
2.
3. {\$mode objfpc}{\$H+}
4.
5. interface
6.
7. uses
8.   Classes, SysUtils, Controls, ExtCtrls, graphics, math;
9.
10. Type
11.   TPB_Slider = class(TCustomControl)
12.   protected
13.     fVertical:boolean;
14.     fMax,fMin,fDefaultSize:Integer;
15.     fMaxRange,fMinRange:Integer;
16.     procedure setVertical(Value:Boolean);
17.     procedure setMax(Value:Integer);
18.     procedure setMin(Value:Integer);
19.     procedure setMaxRange(Value:Integer);
20.     procedure setMinRange(Value:Integer);
21.   private
22.     FRuleSize,
23.     BtnSize: TPoint;
24.     FCapturePosition: Byte;
25.     fCaptureDeslocate,fRuleStart:Integer;
26.     function GetRectFromPoint(Position:Integer;Alignment:TAlignment):TRect;
27.   public
28.     constructor Create(TheOwner: TComponent);override;
29.     Destructor Destroy; override;
30.     Procedure Paint; override;
31.     procedure Resize; override;
32.     procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
33.     procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
34.     procedure MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
35.     procedure MouseLeave; override;
36.     property MaxPosition:Integer read fMax write setMax;
37.     property MinPosition:Integer read fMin write setMin;
38.     Property MaxRange:Integer read fMaxRange write setMaxRange;
39.     Property MinRange:Integer read fMinRange write setMinRange;
40.     property Vertical:boolean read fvertical write setVertical;
41. end;
42.
43. implementation
44.
45. operator in (const A: TPoint; const B: TRect): boolean;
46. begin
47.   Result := (b.Left<=a.x) and (b.top<=a.y) and (b.Right>=a.x) and (b.Bottom>=a.y);
48. end;
49.
50. Destructor TPB_Slider.Destroy;
51. begin
52.   inherited Destroy;
53. end;
54. constructor TPB_Slider.Create(TheOwner: TComponent);
55. begin
56.   inherited Create(TheOwner);
57.   FCapturePosition:=0;
58.   fDefaultSize:=Scale96ToFont(28);
59.   fRuleStart:=fDefaultSize*9 div 16+2;
60.   setVertical(true);
61.   fmin:=20;
62.   fmax:=80;
63.   fminrange:=0;
64.   fmaxrange:=100;
65. end;
66. procedure TPB_Slider.setVertical(Value:Boolean);
67. var
68.   ButtonSize:Integer;
69. begin
70.     fvertical:=value;
71.     ButtonSize:=fDefaultSize*5 div 8;
72.     if vertical then begin
73.       BtnSize:= Point(fDefaultSize,ButtonSize);
74.       FRuleSize:=Point( BtnSize.x div 4, height-fRuleStart*2);
75.     end else begin
76.       BtnSize:= Point(ButtonSize,fDefaultSize);
77.       FRuleSize:=Point( Width-fRuleStart*2,BtnSize.y div 4);
78.     end;
79.     invalidate;
80. end;
81. function TPB_Slider.GetRectFromPoint(Position:Integer;Alignment:TAlignment):Trect;
82. var
83.   Distortion:Integer;
84. begin
85.   if vertical then begin
86.       case Alignment of
87.         taLeftJustify : Distortion:=-BtnSize.y ;
88.         taRightJustify: Distortion:= 0 ;
89.         taCenter      : Distortion:= -BtnSize.y div 2;
90.       end;
91.       Result.Left:=fRuleStart+(FRuleSize.x-BtnSize.x) div 2;
92.       Result.Top:=fRuleStart+Round((FRuleSize.y)*(Position-Fminrange)/(fMaxRange-fMinRange))+Distortion;
93.   end else begin
94.       case Alignment of
95.         taLeftJustify : Distortion:=-BtnSize.x ;
96.         taRightJustify: Distortion:= 0;
97.         taCenter      : Distortion:= -BtnSize.x div 2;
98.       end;
99.       Result.Left:=fRuleStart+Round((FRuleSize.x)*(Position-Fminrange)/(fMaxRange-fMinRange))+Distortion;
100.       Result.Top:=fRuleStart+(FRuleSize.y-BtnSize.y) div 2;
101.   end;
102.   result.Right :=BtnSize.x + result.left;
103.   result.Bottom:=BtnSize.y + result.top ;
104. end;
105.
106. procedure TPB_Slider.Paint;
107. var
108.   RoundRectXY:Integer;
109.   Rule,rang,btn1,btn2:Trect;
110.   Deslocate:TPoint;
112.   var
113.     start,ending,distances,centerpoint,loop:integer;
114.   begin
115.     distances:=fDefaultSize div 8;
116.     start:=MyRect.left+BtnSize.x div 2-distances*8 div 5;
117.     ending:=start+distances*16 div 5;
118.     CenterPoint:=(MyRect.Bottom-MyRect.Top) div 2 +MyRect.Top;
119.     for loop:=-1 to 1 do begin
120.       Canvas.pen.Color:=MyHilight;
121.       Canvas.MoveTo(start ,CenterPoint-1+loop*distances);
122.       Canvas.lineto(ending,CenterPoint-1+loop*distances);
123.
124.       Canvas.pen.Color:=MyColor;
125.       Canvas.MoveTo(start ,CenterPoint  +loop*distances);
126.       Canvas.lineto(ending,CenterPoint  +loop*distances);
127.
129.       Canvas.MoveTo(start ,CenterPoint+1+loop*distances);
130.       Canvas.lineto(ending,CenterPoint+1+loop*distances);
131.     end;
132.   end;
133.
134.   procedure DrawMyRect(MyRect:Trect;X1,Y1,x2,y2:integer;MyColor:TColor);
135.   begin
136.     Canvas.pen.Color:=MyColor;
137.     Canvas.Brush.Color:=Canvas.pen.Color;
138.     Canvas.RoundRect(MyRect.Left+x1,MyRect.top+y1,MyRect.Right+x2,MyRect.Bottom+y2,RoundRectXY,RoundRectXY);
139.   end;
140. begin
141.   if vertical then begin
142.     Rule.Left:=BtnSize.y;
143.     Rule.top:=fRuleStart;
144.   end else begin
145.     Rule.Left:=fRuleStart;
146.     Rule.top:=BtnSize.x;
147. end;
148.   Rule.Right:=Rule.left+FRuleSize.x;
149.   Rule.Bottom:=Rule.top+FRuleSize.y;
150.
151.   btn1:=GetRectFromPoint(fMin,taLeftJustify);
152.   btn2:=GetRectFromPoint(fMax,taRightJustify);
153.
154.   if vertical then begin
155.     deslocate:=Point(0,BtnSize.y);
156.     rang.Top:=btn1.Bottom;
157.     rang.Bottom:=btn2.top;
158.     rang.left:=rule.Left;
159.     rang.Right:=rule.Right;
160.   end else begin
161.     deslocate:=Point(BtnSize.x,0);
162.     rang.Top:=rule.top;
163.     rang.Bottom:=rule.Bottom;
164.     rang.left:=btn1.Right;
165.     rang.Right:=btn2.Left;
166.   end;
167.   RoundRectXY:=min(FRuleSize.x,FRuleSize.y);
168.   DrawMyRect(rule,-2-deslocate.x,-2-deslocate.y, 0+deslocate.x, 0+deslocate.y,clBtnShadow);
169.   DrawMyRect(rule, 0-deslocate.x, 0-deslocate.y, 2+deslocate.x, 2+deslocate.y,clBtnHighlight);
170.   DrawMyRect(rule,-1-deslocate.x,-1-deslocate.y, 1+deslocate.x, 1+deslocate.y,clInactiveCaption);
171.   RoundRectXY:=0;
172.   DrawMyRect(rang,-2,-2,2,2,clActiveCaption);
173.   RoundRectXY:=min(BtnSize.x,BtnSize.y) div 2;
174.   DrawMyRect(btn1, 0, 0, -1, -1,clBtnHighlight);
175.   DrawMyRect(btn1, 1, 1, 0, 0,clBtnShadow   );
176.   DrawMyRect(btn1, 1, 1, -1, -1,clBtnFace     );
178.   DrawMyRect(btn2, 0, 0, -1, -1,clBtnHighlight);
179.   DrawMyRect(btn2, 1, 1, 0, 0,clBtnShadow   );
180.   DrawMyRect(btn2, 1, 1, -1, -1,clBtnFace     );
182. end;
183. procedure TPB_Slider.MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer);
184. var
185.   PP:Tpoint;
186.   Btn:TRect;
187. begin
188.   PP:=Point(x,y);
189.   btn:=GetRectFromPoint(fmin,taLeftJustify);
190.   if pp in btn then begin
191.       FCapturePosition:=1;
192.       FcaptureDeslocate:=ifthen(vertical,y-btn.Bottom,x-btn.Right);
193.   end else begin
194.     btn:=GetRectFromPoint(fmax,taRightJustify);
195.     if pp in btn then begin
196.        FCapturePosition:=2;
197.        FcaptureDeslocate:=ifthen(vertical,y-btn.top,x-btn.left);
198.     end else FCapturePosition:=0;
199.   end;
200.   inherited MouseDown(Button,Shift,x,y);
201. end;
202.
203. procedure TPB_Slider.MouseMove(Shift: TShiftState; X,Y: Integer);
204. var
205.   PP:Tpoint;
206.   Btn:TRect;
207. begin
208.   case FCapturePosition of
209.     0: begin
210.         PP:=Point(x,y);
211.         btn:=GetRectFromPoint(fmin,taLeftJustify);
212.         if pp in btn then begin
213.           cursor:=crHandPoint;
214.         end else begin
215.           btn:=GetRectFromPoint(fmax,taRightJustify);
216.           if pp in btn then begin
217.             cursor:=crHandPoint;
218.           end else cursor:=crDefault;
219.         end;
220.        end;
221.     1: begin
222.           if vertical then
223.             setMin(round(fMinRange+(fMaxRange-fMinRange)*(y-fRuleStart-FcaptureDeslocate)/FRuleSize.y))
224.           else
225.             setMin(round(fMinRange+(fMaxRange-fMinRange)*(x-fRuleStart-FcaptureDeslocate)/FRuleSize.x))
226.        end;
227.     2: begin
228.           if vertical then
229.             setMax(round(fMinRange+(fMaxRange-fMinRange)*(y-fRuleStart-FcaptureDeslocate)/FRuleSize.y))
230.           else
231.             setMax(round(fMinRange+(fMaxRange-fMinRange)*(x-fRuleStart-FcaptureDeslocate)/FRuleSize.x))
232.        end;
233.   end;
234.   inherited MouseMove(Shift,x,y);
235. end;
236. procedure TPB_Slider.MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer);
237. begin
238.   FCapturePosition:=0;
239.   inherited MouseUp(Button,Shift,x,y);
240. end;
241.
242. procedure TPB_Slider.MouseLeave;
243. begin
244.   inherited MouseLeave;
245.   FCapturePosition:=0;
246. end;
247. procedure TPB_Slider.setMax(Value:Integer);
248. begin
249.    fMax:=min(max(Value,MinRange),MaxRange);
250.    fmin:=min(fmax,fmin);
251.    invalidate;
252. end;
253. procedure TPB_Slider.setMin(Value:Integer);
254. begin
255.   fMin:=max(min(Value,MaxRange),MinRange);
256.   fmax:=max(fmax,fmin);
257.   invalidate;
258. end;
259. procedure TPB_Slider.setMaxRange(Value:Integer);
260. begin
261.   fMaxRange:=Value;
262.   invalidate;
263. end;
264. procedure TPB_Slider.setMinRange(Value:Integer);
265. begin
266.   fMinRange:=Value;
267.   invalidate;
268. end;
269. procedure TPB_Slider.resize;
270. begin
271.   setvertical(fvertical);
272. end;
273.
274. end.
275.

#### apeoperaio

• Full Member
• Posts: 198
##### Re: Slider with 2 Knobs
« Reply #2 on: April 19, 2019, 09:30:06 am »
I will check in the next days!

#### kapibara

• Hero Member
• Posts: 532
##### Re: Slider with 2 Knobs
« Reply #3 on: April 19, 2019, 03:35:29 pm »
Nice!
Lazarus trunk / fpc 3.0.4 / Debian 10 - 64 bit

#### bylaardt

• Sr. Member
• Posts: 308
##### Re: Slider with 2 Knobs
« Reply #4 on: April 19, 2019, 04:02:30 pm »
thanks for test it on windows

#### wp

• Hero Member
• Posts: 7948
##### Re: Slider with 2 Knobs
« Reply #5 on: April 19, 2019, 04:24:27 pm »
challenge accepted! so I did it from scratch!
This is by far the nicest multi-slider that I've seen among those published on torry.net for Delphi. Would you allow me to add it to the Industrial package on CCR and make some minor adjustments (e.g. add an optional 3rd slider, optionally draw ticks)? If yes, any license suggestions? Otherwise I'd add the standard LCL license header (LGPL modified)
Mainly Lazarus trunk / fpc 3.2.0 / all 32-bit on Win-10, but many more...

#### bylaardt

• Sr. Member
• Posts: 308
##### Re: Slider with 2 Knobs
« Reply #6 on: April 19, 2019, 06:30:41 pm »
Would you allow me to add it to the Industrial package on CCR and make some minor adjustments (e.g. add an optional 3rd slider, optionally draw ticks)?
of course. I glad you like it.
If yes, any license suggestions? Otherwise I'd add the standard LCL license header (LGPL modified)
I've always posted my projects in the public domain license, but the LGPL is fine, btw is even better

#### Blaazen

• Hero Member
• Posts: 3009
• POKE 54296,15
##### Re: Slider with 2 Knobs
« Reply #7 on: April 19, 2019, 07:25:23 pm »
Even my EC-Controls doesn't have two knob slider. I'll think about it.
Lazarus 2.1.0 r64115 FPC 3.3.1 r40507 x86_64-linux-qt Chakra, Qt 4.8.7/5.13.2, Plasma 5.17.3
Lazarus 1.8.2 r57369 FPC 3.0.4 i386-win32-win32/win64 Wine 3.21

Try Eye-Candy Controls: https://sourceforge.net/projects/eccontrols/files/

#### sstvmaster

• Full Member
• Posts: 190
##### Re: Slider with 2 Knobs
« Reply #8 on: April 19, 2019, 09:59:52 pm »
@bylaardt, many thanks!!

Windows 10 (64 bit)
Lazarus: 2.0.10 / Trunk x32

#### wp

• Hero Member
• Posts: 7948
##### Re: Slider with 2 Knobs
« Reply #9 on: April 21, 2019, 11:38:07 pm »
bylaardt's component is now included in the Industrial package on CCR (https://sourceforge.net/p/lazarus-ccr/svn/HEAD/tree/components/industrialstuff/) in unit indSliders as TMultiSlider. Once it has stabilized I'll ask for updating the OPM version.

I added several new features:
• selection of thumb style (grip as in bylaardt's original, circle, box, rounded box, triangles)
• selection of thumb count (1, 2, 3); note that positioning of the center slider in the 3-slider case is not very precise and may overlap with the limiting min/max sliders. Use the triangle thumb for better precision.
• selection of colors for "thumb" as well as "below", "between" and "above" parts of the slider track
• flat or slightly recessed presentation
• event OnPositionChange having the related thumb as a parameter.
• Unlike bylaardt's version, the slider positions cannot be changed by pushing for example the min slider to the max slider; slider positions are fixed and can only be changed by dragging them with the mouse directly

In the attachment there is a screen shot of the demo program with parameters set up to come close to the original request.

Mainly Lazarus trunk / fpc 3.2.0 / all 32-bit on Win-10, but many more...

#### sstvmaster

• Full Member
• Posts: 190
##### Re: Slider with 2 Knobs
« Reply #10 on: April 22, 2019, 12:44:00 am »
Thanks wp!
Windows 10 (64 bit)
Lazarus: 2.0.10 / Trunk x32

#### Alextp

• Hero Member
• Posts: 1170
##### Re: Slider with 2 Knobs
« Reply #11 on: April 22, 2019, 09:57:12 am »
Good work on new slider version.

#### apeoperaio

• Full Member
• Posts: 198
##### Re: Slider with 2 Knobs
« Reply #12 on: April 23, 2019, 11:43:06 am »
@bylaardt and @wp thank you very much!

Lazarus is a wonderful tool and it has an amazing community!

#### kapibara

• Hero Member
• Posts: 532
##### Re: Slider with 2 Knobs
« Reply #13 on: May 08, 2019, 08:15:31 pm »
@wp I can't decide if this is this a cool feature or a bug. Check the picture. When using different colors for the sliders knob and track, are the small lines leftover pixels?

Lazarus trunk / fpc 3.0.4 / Debian 10 - 64 bit

#### wp

• Hero Member
• Posts: 7948
##### Re: Slider with 2 Knobs
« Reply #14 on: May 08, 2019, 09:51:18 pm »
It is not intended. Can you post a small project so that I can have a closer look?
Mainly Lazarus trunk / fpc 3.2.0 / all 32-bit on Win-10, but many more...