Lazarus

Programming => Packages and Libraries => Topic started by: apeoperaio on April 16, 2019, 11:07:39 am

Title: Slider with 2 Knobs
Post by: apeoperaio 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
Title: Re: Slider with 2 Knobs
Post by: bylaardt 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.  
Title: Re: Slider with 2 Knobs
Post by: apeoperaio on April 19, 2019, 09:30:06 am
I will check in the next days!
Title: Re: Slider with 2 Knobs
Post by: kapibara on April 19, 2019, 03:35:29 pm
Nice!
Title: Re: Slider with 2 Knobs
Post by: bylaardt on April 19, 2019, 04:02:30 pm
thanks for test it on windows
Title: Re: Slider with 2 Knobs
Post by: wp 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)
Title: Re: Slider with 2 Knobs
Post by: bylaardt 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
Title: Re: Slider with 2 Knobs
Post by: Blaazen on April 19, 2019, 07:25:23 pm
Even my EC-Controls doesn't have two knob slider. I'll think about it.  8)
Title: Re: Slider with 2 Knobs
Post by: sstvmaster on April 19, 2019, 09:59:52 pm
@bylaardt, many thanks!!

@wp or Blaazen, please add.
Title: Re: Slider with 2 Knobs
Post by: wp 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:

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

Title: Re: Slider with 2 Knobs
Post by: sstvmaster on April 22, 2019, 12:44:00 am
Thanks wp!
Title: Re: Slider with 2 Knobs
Post by: Alextp on April 22, 2019, 09:57:12 am
Good work on new slider version.
Title: Re: Slider with 2 Knobs
Post by: apeoperaio 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!
Title: Re: Slider with 2 Knobs
Post by: kapibara 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?

Title: Re: Slider with 2 Knobs
Post by: wp 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?
Title: Re: Slider with 2 Knobs
Post by: kapibara on May 08, 2019, 11:08:45 pm
Sure. There is no code inside, except this.

Code: Pascal  [Select]
  1. procedure TForm1.FormCreate(Sender: TObject);
  2. begin
  3.   MultiSlider1.ColorAbove:= clRed;
  4.   MultiSlider1.ColorBelow:= clGreen;
  5.   MultiSlider1.ColorBetween:= clWhite;
  6. end;
  7.