Recent

Author Topic: Slider with 2 Knobs  (Read 1445 times)

apeoperaio

  • Full Member
  • ***
  • Posts: 157
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?
See as example here: http://developer.expressionz.in/downloads/mootools_double_pinned_slider_with_clipped_gutter_image_v2.2/slider_using_mootols_1.2.html

Or the attached image
Thanks,
Andrea

bylaardt

  • Sr. Member
  • ****
  • Posts: 303
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;
  111. procedure DrawMyLine(MyRect:TRect;MyColor,MyShadow,MyHilight:TColor);
  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.  
  128.       Canvas.pen.Color:=MyShadow;
  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     );
  177.   DrawMyLine(btn1,clBtnFace,clBtnShadow,clBtnHighlight);
  178.   DrawMyRect(btn2, 0, 0, -1, -1,clBtnHighlight);
  179.   DrawMyRect(btn2, 1, 1, 0, 0,clBtnShadow   );
  180.   DrawMyRect(btn2, 1, 1, -1, -1,clBtnFace     );
  181.   DrawMyLine(btn2,clBtnFace,clBtnShadow,clBtnHighlight);
  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: 157
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: 511
Re: Slider with 2 Knobs
« Reply #3 on: April 19, 2019, 03:35:29 pm »
Nice!
Lazarus trunk / fpc 3.0.4 / Debian Stretch 64-bit

bylaardt

  • Sr. Member
  • ****
  • Posts: 303
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: 6158
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)
Lazarus trunk / fpc 3.0.4 / all 32-bit on Win-10

bylaardt

  • Sr. Member
  • ****
  • Posts: 303
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: 2782
  • POKE 54296,15
    • Eye-Candy Controls
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.  8)
Lazarus 2.1.0 r59757M FPC 3.3.1 r40507 x86_64-linux-qt Chakra, Qt 4.8.7/5.11.2, Plasma 5.14.2
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: 118
Re: Slider with 2 Knobs
« Reply #8 on: April 19, 2019, 09:59:52 pm »
@bylaardt, many thanks!!

@wp or Blaazen, please add.
Lazarus 2.0.4 x32
Lazarus 2.1.0 Trunk x32
OS Win 7 32bit

wp

  • Hero Member
  • *****
  • Posts: 6158
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.

Lazarus trunk / fpc 3.0.4 / all 32-bit on Win-10

sstvmaster

  • Full Member
  • ***
  • Posts: 118
Re: Slider with 2 Knobs
« Reply #10 on: April 22, 2019, 12:44:00 am »
Thanks wp!
Lazarus 2.0.4 x32
Lazarus 2.1.0 Trunk x32
OS Win 7 32bit

Alextp

  • Hero Member
  • *****
  • Posts: 855
    • UVviewsoft
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: 157
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: 511
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 Stretch 64-bit

wp

  • Hero Member
  • *****
  • Posts: 6158
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?
Lazarus trunk / fpc 3.0.4 / all 32-bit on Win-10