unit pb_slider;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Controls, ExtCtrls, graphics, math;
Type
TPB_Slider = class(TCustomControl)
protected
fVertical:boolean;
fMax,fMin,fDefaultSize:Integer;
fMaxRange,fMinRange:Integer;
procedure setVertical(Value:Boolean);
procedure setMax(Value:Integer);
procedure setMin(Value:Integer);
procedure setMaxRange(Value:Integer);
procedure setMinRange(Value:Integer);
private
FRuleSize,
BtnSize: TPoint;
FCapturePosition: Byte;
fCaptureDeslocate,fRuleStart:Integer;
function GetRectFromPoint(Position:Integer;Alignment:TAlignment):TRect;
public
constructor Create(TheOwner: 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;
property MaxPosition:Integer read fMax write setMax;
property MinPosition:Integer read fMin write setMin;
Property MaxRange:Integer read fMaxRange write setMaxRange;
Property MinRange:Integer read fMinRange write setMinRange;
property Vertical:boolean read fvertical write setVertical;
end;
implementation
operator in (const A: TPoint; const B: TRect): boolean;
begin
Result := (b.Left<=a.x) and (b.top<=a.y) and (b.Right>=a.x) and (b.Bottom>=a.y);
end;
Destructor TPB_Slider.Destroy;
begin
inherited Destroy;
end;
constructor TPB_Slider.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
FCapturePosition:=0;
fDefaultSize:=Scale96ToFont(28);
fRuleStart:=fDefaultSize*9 div 16+2;
setVertical(true);
fmin:=20;
fmax:=80;
fminrange:=0;
fmaxrange:=100;
end;
procedure TPB_Slider.setVertical(Value:Boolean);
var
ButtonSize:Integer;
begin
fvertical:=value;
ButtonSize:=fDefaultSize*5 div 8;
if vertical then begin
BtnSize:= Point(fDefaultSize,ButtonSize);
FRuleSize:=Point( BtnSize.x div 4, height-fRuleStart*2);
end else begin
BtnSize:= Point(ButtonSize,fDefaultSize);
FRuleSize:=Point( Width-fRuleStart*2,BtnSize.y div 4);
end;
invalidate;
end;
function TPB_Slider.GetRectFromPoint(Position:Integer;Alignment:TAlignment):Trect;
var
Distortion:Integer;
begin
if vertical then begin
case Alignment of
taLeftJustify : Distortion:=-BtnSize.y ;
taRightJustify: Distortion:= 0 ;
taCenter : Distortion:= -BtnSize.y div 2;
end;
Result.Left:=fRuleStart+(FRuleSize.x-BtnSize.x) div 2;
Result.Top:=fRuleStart+Round((FRuleSize.y)*(Position-Fminrange)/(fMaxRange-fMinRange))+Distortion;
end else begin
case Alignment of
taLeftJustify : Distortion:=-BtnSize.x ;
taRightJustify: Distortion:= 0;
taCenter : Distortion:= -BtnSize.x div 2;
end;
Result.Left:=fRuleStart+Round((FRuleSize.x)*(Position-Fminrange)/(fMaxRange-fMinRange))+Distortion;
Result.Top:=fRuleStart+(FRuleSize.y-BtnSize.y) div 2;
end;
result.Right :=BtnSize.x + result.left;
result.Bottom:=BtnSize.y + result.top ;
end;
procedure TPB_Slider.Paint;
var
RoundRectXY:Integer;
Rule,rang,btn1,btn2:Trect;
Deslocate:TPoint;
procedure DrawMyLine(MyRect:TRect;MyColor,MyShadow,MyHilight:TColor);
var
start,ending,distances,centerpoint,loop:integer;
begin
distances:=fDefaultSize div 8;
start:=MyRect.left+BtnSize.x div 2-distances*8 div 5;
ending:=start+distances*16 div 5;
CenterPoint:=(MyRect.Bottom-MyRect.Top) div 2 +MyRect.Top;
for loop:=-1 to 1 do begin
Canvas.pen.Color:=MyHilight;
Canvas.MoveTo(start ,CenterPoint-1+loop*distances);
Canvas.lineto(ending,CenterPoint-1+loop*distances);
Canvas.pen.Color:=MyColor;
Canvas.MoveTo(start ,CenterPoint +loop*distances);
Canvas.lineto(ending,CenterPoint +loop*distances);
Canvas.pen.Color:=MyShadow;
Canvas.MoveTo(start ,CenterPoint+1+loop*distances);
Canvas.lineto(ending,CenterPoint+1+loop*distances);
end;
end;
procedure DrawMyRect(MyRect:Trect;X1,Y1,x2,y2:integer;MyColor:TColor);
begin
Canvas.pen.Color:=MyColor;
Canvas.Brush.Color:=Canvas.pen.Color;
Canvas.RoundRect(MyRect.Left+x1,MyRect.top+y1,MyRect.Right+x2,MyRect.Bottom+y2,RoundRectXY,RoundRectXY);
end;
begin
if vertical then begin
Rule.Left:=BtnSize.y;
Rule.top:=fRuleStart;
end else begin
Rule.Left:=fRuleStart;
Rule.top:=BtnSize.x;
end;
Rule.Right:=Rule.left+FRuleSize.x;
Rule.Bottom:=Rule.top+FRuleSize.y;
btn1:=GetRectFromPoint(fMin,taLeftJustify);
btn2:=GetRectFromPoint(fMax,taRightJustify);
if vertical then begin
deslocate:=Point(0,BtnSize.y);
rang.Top:=btn1.Bottom;
rang.Bottom:=btn2.top;
rang.left:=rule.Left;
rang.Right:=rule.Right;
end else begin
deslocate:=Point(BtnSize.x,0);
rang.Top:=rule.top;
rang.Bottom:=rule.Bottom;
rang.left:=btn1.Right;
rang.Right:=btn2.Left;
end;
RoundRectXY:=min(FRuleSize.x,FRuleSize.y);
DrawMyRect(rule,-2-deslocate.x,-2-deslocate.y, 0+deslocate.x, 0+deslocate.y,clBtnShadow);
DrawMyRect(rule, 0-deslocate.x, 0-deslocate.y, 2+deslocate.x, 2+deslocate.y,clBtnHighlight);
DrawMyRect(rule,-1-deslocate.x,-1-deslocate.y, 1+deslocate.x, 1+deslocate.y,clInactiveCaption);
RoundRectXY:=0;
DrawMyRect(rang,-2,-2,2,2,clActiveCaption);
RoundRectXY:=min(BtnSize.x,BtnSize.y) div 2;
DrawMyRect(btn1, 0, 0, -1, -1,clBtnHighlight);
DrawMyRect(btn1, 1, 1, 0, 0,clBtnShadow );
DrawMyRect(btn1, 1, 1, -1, -1,clBtnFace );
DrawMyLine(btn1,clBtnFace,clBtnShadow,clBtnHighlight);
DrawMyRect(btn2, 0, 0, -1, -1,clBtnHighlight);
DrawMyRect(btn2, 1, 1, 0, 0,clBtnShadow );
DrawMyRect(btn2, 1, 1, -1, -1,clBtnFace );
DrawMyLine(btn2,clBtnFace,clBtnShadow,clBtnHighlight);
end;
procedure TPB_Slider.MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer);
var
PP:Tpoint;
Btn:TRect;
begin
PP:=Point(x,y);
btn:=GetRectFromPoint(fmin,taLeftJustify);
if pp in btn then begin
FCapturePosition:=1;
FcaptureDeslocate:=ifthen(vertical,y-btn.Bottom,x-btn.Right);
end else begin
btn:=GetRectFromPoint(fmax,taRightJustify);
if pp in btn then begin
FCapturePosition:=2;
FcaptureDeslocate:=ifthen(vertical,y-btn.top,x-btn.left);
end else FCapturePosition:=0;
end;
inherited MouseDown(Button,Shift,x,y);
end;
procedure TPB_Slider.MouseMove(Shift: TShiftState; X,Y: Integer);
var
PP:Tpoint;
Btn:TRect;
begin
case FCapturePosition of
0: begin
PP:=Point(x,y);
btn:=GetRectFromPoint(fmin,taLeftJustify);
if pp in btn then begin
cursor:=crHandPoint;
end else begin
btn:=GetRectFromPoint(fmax,taRightJustify);
if pp in btn then begin
cursor:=crHandPoint;
end else cursor:=crDefault;
end;
end;
1: begin
if vertical then
setMin(round(fMinRange+(fMaxRange-fMinRange)*(y-fRuleStart-FcaptureDeslocate)/FRuleSize.y))
else
setMin(round(fMinRange+(fMaxRange-fMinRange)*(x-fRuleStart-FcaptureDeslocate)/FRuleSize.x))
end;
2: begin
if vertical then
setMax(round(fMinRange+(fMaxRange-fMinRange)*(y-fRuleStart-FcaptureDeslocate)/FRuleSize.y))
else
setMax(round(fMinRange+(fMaxRange-fMinRange)*(x-fRuleStart-FcaptureDeslocate)/FRuleSize.x))
end;
end;
inherited MouseMove(Shift,x,y);
end;
procedure TPB_Slider.MouseUp(Button: TMouseButton; Shift:TShiftState; X,Y:Integer);
begin
FCapturePosition:=0;
inherited MouseUp(Button,Shift,x,y);
end;
procedure TPB_Slider.MouseLeave;
begin
inherited MouseLeave;
FCapturePosition:=0;
end;
procedure TPB_Slider.setMax(Value:Integer);
begin
fMax:=min(max(Value,MinRange),MaxRange);
fmin:=min(fmax,fmin);
invalidate;
end;
procedure TPB_Slider.setMin(Value:Integer);
begin
fMin:=max(min(Value,MaxRange),MinRange);
fmax:=max(fmax,fmin);
invalidate;
end;
procedure TPB_Slider.setMaxRange(Value:Integer);
begin
fMaxRange:=Value;
invalidate;
end;
procedure TPB_Slider.setMinRange(Value:Integer);
begin
fMinRange:=Value;
invalidate;
end;
procedure TPB_Slider.resize;
begin
setvertical(fvertical);
end;
end.