Gallery
Software
Music
Programming
Archive
Wednesday, Jan 16 Week 3

TFader and TRotary

Simple fader and rotary component for Delphi.



Download example

fader-rotary.zip
(214.77 Kb)
, Downloads: 462

faderRotary

unit faderRotary;

interface

uses
windows,classes,controls,graphics,messages;

{$R faderRotary.dcr}

type
TSimpleEvent = procedure of object;//no arguments
TStateEvent = procedure(sender:TObject;user:boolean) of object;
TVsEvent = procedure(e:byte;x,y:longInt;key:byte;sender:TObject) of object;
//--------------------------|---------------------|-----------------------|-------------------------<
TCustomFader=class(TCustomControl) //for descendants
function event(e:byte;x,y:longInt;key:byte=0):boolean;virtual;
procedure Resize;override;//for descendants
procedure updateImg;virtual;//for descendants
function screenXY:TPoint;
function screenRect:TRect;
protected
ms :boolean;
fPercent,fInitValue :double;
fMin,fMax :double;
fRoundedValue :boolean;
fSpacing :byte;
fColorKnob :TColor;
fBevelWidth :byte;
fOnPosition :TStateEvent;
started :boolean;
fPressed :boolean; //left mouse button is pressed on this object
fOnEvent :TVsEvent;
fDesignMode :boolean;
procedure MouseMove(shift:TShiftState;x,y:integer);override;
procedure MouseDown(button:TMouseButton;shift:TShiftState;x,y:integer);override;
procedure MouseUp(button:TMouseButton;shift:TShiftState;x,y:integer);override;
procedure Click;override;
procedure CreateParams(var params:TCreateParams);override;
procedure WMGetDlgCode(var msg:TWmGetDlgCode);message WM_GETDLGCODE;
procedure WndProc(var msg:TMessage);override;
function getValue:double;
procedure setValue(f:double);
function getValueInt:longInt;
procedure setValueInt(i:longInt);
procedure setPercent(f:double);
procedure setMin(f:double);
procedure setMax(f:double);
procedure setRoundedValue(bl:boolean);
procedure setSpacing(n:byte);
procedure setBevelWidth(w:byte);
procedure setColorKnob(cl:TColor);
public
useTabKey :boolean;
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
procedure SetFocus;override;
property designMode :boolean read fDesignMode;
published
property onEvent :TVsEvent read fOnEvent write fOnEvent;
property bevelWidth :byte read fBevelWidth write setBevelWidth;
property colorKnob :TColor read fColorKnob write setColorKnob;
property min :double read fMin write setMin;
property max :double read fMax write setMax;
property percent :double read fPercent write setPercent;
property initValue :double read fInitValue write fInitValue;
property roundedValue :boolean read fRoundedValue write setRoundedValue;
property spacing :byte read fSpacing write setSpacing;
property value :double read getValue write setValue;
property valueInt :longInt read getValueInt write setValueInt;
property onPosition :TStateEvent read fOnPosition write fOnPosition;
property onMouseUp;
property onClick;
property align;
property color;
property cursor;
property enabled;
property hint;
property showHint;
property popUpMenu;
property visible;
end;
//--------------------------|---------------------|-----------------------|-------------------------<
TFader=class(TCustomFader)
function event(e:byte;x,y:longInt;key:byte=0):boolean;override;
private
procedure setVertical(bl:boolean);
procedure setKnobSize(n:word);
procedure setLineSize(n:byte);
procedure setColorLine(cl:TColor);
protected
fColorLine :TColor;
fKnobSize :word;
fLineSize :byte;
fVertical :boolean;
fKnobImg :TBitmap;
procedure Paint;override;
procedure scrollToPos(n:longInt);
public
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
published
property colorLine :TColor read fColorLine write setColorLine;
property knobSize :word read fKnobSize write setKnobSize;
property lineSize :byte read fLineSize write setLineSize;
property vertical :boolean read fVertical write setVertical;
property knobImg :TBitmap read fKnobImg write fKnobImg;
end;
//--------------------------|---------------------|-----------------------|-------------------------<
TRotary=class(TCustomFader)
function event(e:byte;x,y:longInt;key:byte=0):boolean;override;
protected
mbX,mbY :longInt;
mbPos :double;
painting :bool;
fArrowWidth :byte;
fColorArrow :TColor;
fRoundArrow :boolean;
procedure Paint;override;
procedure setColorArrow(cl:TColor);
procedure setArrowWidth(b:byte);
procedure setRoundArrow(bl:boolean);
public
constructor Create(AOwner:TComponent);override;
published
property arrowWidth :byte read fArrowWidth write setArrowWidth;
property colorArrow :TColor read fColorArrow write setColorArrow;
property roundArrow :boolean read fRoundArrow write setRoundArrow;
end;
//--------------------------|---------------------|-----------------------|-------------------------<

const
EVENT_CLICK = $01; //Mouse, Click
EVENT_LDN = $03; //Mouse, Left button, down
EVENT_LUP = $04; //Mouse, Left button, up
EVENT_MDN = $05; //Mouse, Middle button, down
EVENT_MUP = $06; //Mouse, Middle button, up
EVENT_RDN = $07; //Mouse, Right button, down
EVENT_RUP = $08; //Mouse, Right button, up
EVENT_MMOVE = $09; //Mouse, Move

function colorBright(cl:TColor;amt:smallInt=$7E):TColor;
procedure drawBevel(bg:TCanvas;x1,y1,x2,y2,sz,sp:longInt;cl:TColor;range:byte=$33);
procedure roundBevel(bg:TCanvas;cX,cY,rad,sz,width,height:longInt;aAngle:double);
procedure drawRotary(bg:TCanvas;x,y,w,h:word;pct:double;sp,brd,bvl,arrow:byte;enabled,tr:bool;cl,clKnob,clBrd,clArrow:TColor);
procedure drawFader(bg:TCanvas;w,h:word;vert:bool;pct:double;sp,brd,bvl,lineSz,knobSz:byte;enabled,tr:bool;cl,clKnob,clBrd,clLine:TColor;knobImg:TBitmap);

//..
procedure Register;

implementation

const
E_MOUSEDN:array[TMouseButton] of byte=(EVENT_LDN,EVENT_RDN,EVENT_MDN); //MouseDown
E_MOUSEUP:array[TMouseButton] of byte=(EVENT_LUP,EVENT_RUP,EVENT_MUP); //MouseUp

function mulDiv(f,m,d:double):double;
begin
if d<>0 then result:=f*m/d else result:=0;
end;

function map(f,aMinA,aMaxA,aMinB,aMaxB:double):double;
begin
result:=mulDiv(f-aMinA,aMaxB-aMinB,aMaxA-aMinA)+aMinB;
if result<aMinB then result:=aMinB else
if result>aMaxB then result:=aMaxB;
end;

procedure sinCos(t:extended;var sin,cos:extended);//from math.pas
asm
FLD t //load t
FSINCOS
FSTP tbyte ptr [edx] // cos
FSTP tbyte ptr [eax] // sin
FWAIT
end;

//convert rect to radius and center pos
function asRadius(x1,y1,x2,y2:longInt;out cX,cY,rX,rY:longInt):boolean;
var dX,dY,i:longInt;
begin
if x1>x2 then begin i:=x1;x1:=x2;x2:=i end;
if y1>y2 then begin i:=y1;y1:=y2;y2:=i end;
dX:=x2-x1;rX:=dX div 2;cX:=rX+x1;
dY:=y2-y1;rY:=dY div 2;cY:=rY+y1;
result:=(dX<>0) and (dY<>0);
end;

procedure radiusToPoint(rX,rY:longInt;angle:double;out x,y:longInt);
const k=2*pi;
var s,c:extended;
begin
sinCos(mulDiv(angle,k,360),s,c);
x:=round(rX*c);
y:=round(rY*s);
end;

procedure lineByAngle(canvas:TCanvas;cX,cY,rX,rY:longInt;angle,l1,l2:double);
var x1,y1,x2,y2:integer;
begin
angle:=360-angle+90;
radiusToPoint(trunc(mulDiv(rX,l2,100)),trunc(mulDiv(rY,l2,100)),angle,x1,y1);
radiusToPoint(trunc(mulDiv(rX,l1,100)),trunc(mulDiv(rY,l1,100)),angle,x2,y2);
canvas.moveTo(cX+x2,cY-y2);
canvas.lineTo(cX+x1,cY-y1);
end;

function colorBright(cl:TColor;amt:smallInt=$7E):TColor;
var r,g,b:longInt;
begin
r:=byte(cl)+amt; if r>$FF then r:=$FF else if r<0 then r:=0;
g:=byte(cl shr 8)+amt; if g>$FF then g:=$FF else if g<0 then g:=0;
b:=byte(cl shr 16)+amt; if b>$FF then b:=$FF else if b<0 then b:=0;
result:=r or (g shl 8) or (b shl 16)
end;

procedure drawBevel(bg:TCanvas;x1,y1,x2,y2,sz,sp:longInt;cl:TColor;range:byte=$33);
var z:word;
begin
if sz<>0 then with bg do begin
inc(x1,sp);dec(x2,sp);
inc(y1,sp);dec(y2,sp);
pen.width:=1;

while sz<>0 do begin
z:=sz-1;
pen.color:=colorBright(cl,RANGE div sz);
moveTo(x1+z,y1+z);lineTo(x2-z,y1+z);
moveTo(x1+z,y1+z);lineTo(x1+z,y2-z);
pen.color:=colorBright(cl,-RANGE div sz);
moveTo(x1+z,y2-z-1);lineTo(x2-z,y2-z-1);
moveTo(x2-z-1,y1+z);lineTo(x2-z-1,y2-z);
dec(sz);
end;

end;
end;

procedure roundBevel(bg:TCanvas;cX,cY,rad,sz,width,height:longInt;aAngle:double);
var i,v,x,y:longInt;t,s,c:extended;a,h,m:byte;hs:word;
begin
s:=pi*rad;
v:=round(s*2);
t:=pi*(1/s);
h:=trunc(aAngle*$FF/360);
if sz=0 then sz:=1;
hs:=sz div 2;
for i:=0 to v do begin
sinCos(t*i,s,c);
y:=cY+round(rad*c);if (y<0) or (y>=height) then continue;//y safety
x:=cX+round(rad*s);if (x<0) or (x>=width) then continue;//x safety
a:=$FF*i div v+h;
m:=a*2;if a<128 then m:=$FF-m;
bg.pen.color:=m or (m shl 8) or (m shl 16);
bg.brush.color:=bg.pen.color;
if sz=1 then bg.pixels[x,y]:=bg.pen.color else
bg.rectangle(x-hs,y-hs,x+hs,y+hs);
end
end;

procedure drawRotary(bg:TCanvas;x,y,w,h:word;pct:double;sp,brd,bvl,arrow:byte;enabled,tr:bool;cl,clKnob,clBrd,clArrow:TColor);
var x1,y1,x2,y2,cX,cY,rX,rY:longInt;f,angle:double;
begin
with bg do begin
if not tr then begin
brush.color:=cl;
fillRect(rect(x,y,w-1,h-1));
end;
if h<w then w:=h;h:=w;
x1:=x+sp;x2:=x+w-sp-1;
y1:=y+sp;y2:=y+h-sp-1;

pen.width:=brd;
if enabled then brush.color:=clKnob else brush.color:=clGray;
if brd<>0 then pen.color:=clBrd else pen.color:=clKnob;
windows.roundRect(handle,x1,y1,x2,y2,x2,y2);

if (bvl<>0) and asRadius(x1+brd,y1+brd,x2-brd,y2-brd,cX,cY,rX,rY) then begin
if rY<rX then rX:=rY;
roundBevel(bg,cX,cY,rX,bvl,w,h,140);
end;

if (arrow<>0) and asRadius(x1,y1,x2,y2,cX,cY,rX,rY) then begin
pen.width:=arrow;
pen.color:=clArrow;
angle:=pct*2.7+225;
if angle>360 then angle:=angle-360;
f:=mulDiv(100,sp,w);
lineByAngle(bg,cX,cY,rX,rY,angle,10+f,90-f);
end;

end;
end;

procedure drawFader(bg:TCanvas;w,h:word;vert:bool;pct:double;sp,brd,bvl,lineSz,knobSz:byte;enabled,tr:bool;cl,clKnob,clBrd,clLine:TColor;knobImg:TBitmap);
var n,x1,y1,x2,y2:longInt;clKn:TColor;
begin
with bg do begin
if not tr then begin
brush.color:=cl;
fillRect(rect(0,0,w,h));
end;

if lineSz<>0 then begin brush.color:=clLine;
if vert then begin
n := w div 2-(lineSz div 2)-1;
x1 := n;
y1 := sp+lineSz;
x2 := x1+lineSz;
y2 := h-sp-lineSz-1;
end else begin
n := h div 2-(lineSz div 2)-1;
x1 := sp+lineSz+1;
y1 := n+1;
x2 := w-sp-lineSz;
y2 := y1+lineSz;
end;
fillRect(rect(x1,y1,x2,y2));
end;

if vert then n:=h else n:=w;
pen.width:=brd;

if enabled then clKn:=clKnob else clKn:=clGray; //also color for bevel

if brd<>0 then pen.color:=clBrd else pen.color:=cl;
n:=trunc(mulDiv(n-knobSz-(sp*2),pct,100));

if vert then begin
n:=h-sp-n-knobSz-1;//inv. vertical direction
x1:=sp; x2:=w-sp-1;
y1:=sp+n+1; y2:=sp+n+knobSz;
end else begin
x1:=sp+n+1; x2:=sp+n+knobSz;
y1:=sp; y2:=h-sp-1;
end;

brush.color:=clKn;

if not knobImg.empty then begin
bg.draw(x1,y1,knobImg);
end else begin
rectangle(x1,y1,x2,y2);
if bvl<>0 then drawBevel(bg,x1,y1,x2,y2,bvl,brd,clKn);
end;

end;
end;

//--------------------------------------------------------------------------------------------------
//TFader:

constructor TFader.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
fVertical := false;
started := true;
fKnobSize := 8;
fLineSize := 3;
fColorLine := $AAAAAA;
fKnobImg := TBitmap.Create;
fKnobImg.pixelFormat := pf24bit;
Resize;
end;

destructor TFader.Destroy;
begin
started:=false;
fKnobImg.free;fKnobImg:=nil;
inherited Destroy;
end;

procedure TFader.setVertical(bl:boolean);
begin
fVertical:=bl;
reSize
end;

procedure TFader.setKnobSize(n:word);
begin
if n<3 then n:=3;
fKnobSize:=n;
reSize
end;

procedure TFader.setLineSize(n:byte);
begin
if n>10 then n:=10;
fLineSize:=n;
reSize
end;

procedure TFader.setColorLine(cl:TColor);
begin
fColorLine:=cl;
if fLineSize<>0 then updateImg
end;

procedure TFader.paint;
begin
if not started then exit;
canvas.brush.color:=color;
canvas.fillRect(rect(0,0,width,height));
drawFader(canvas,width,height,vertical,fPercent,fSpacing,0,fBevelWidth,
fLineSize,fKnobSize,enabled,false,color,fColorKnob,0,fColorLine,fKnobImg);
end;

procedure TFader.scrollToPos(n:longInt);
begin ms:=true;
if fVertical then
setPercent(100-mulDiv(100,n-(fKnobSize div 2),height-fKnobSize)) else
setPercent(mulDiv(100,n-(fKnobSize div 2),width-fKnobSize));
ms:=false
end;

function TFader.event(e:byte;x,y:longInt;key:byte=0):boolean;
begin
result:=inherited event(e,x,y,key);
if result then case e of
EVENT_LUP:if assigned(onMouseUp) then onMouseUp(self,mbLeft,[],x,y);
EVENT_LDN:
if getKeyState(VK_CONTROL)<0 then begin //CTRL is pressed:
ms:=true; //Now user input
setValue(fInitValue);
ms:=false; //No longer user input
fPressed:=false; //User must press mousebutton again, in order to set value from mousemove
end else
if fVertical then scrollToPos(y) else scrollToPos(x);
EVENT_MMOVE:if fPressed then begin
if fVertical then scrollToPos(y) else scrollToPos(x);
end;
end;
end;

//--------------------------------------------------------------------------------------------------
//TRotary:

constructor TRotary.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
fColorArrow := clBlack;
width := 32;
height := 32;
fArrowWidth := 2;
fColorArrow := clWhite;
started := true;
reSize;
end;

procedure TRotary.paint;
begin
if painting or not started then exit;
painting:=true;
canvas.brush.color:=color;
canvas.fillRect(rect(0,0,width,height));
drawRotary(canvas,0,0,width,height,fPercent,fSpacing,0,fBevelWidth,
fArrowWidth,enabled,false,color,fColorKnob,0,fColorArrow);
painting:=false;
end;

procedure TRotary.setColorArrow(cl:TColor);
begin
fColorArrow:=cl;
updateImg;
end;

procedure TRotary.setArrowWidth(b:byte);
begin
if b=0 then b:=1 else
if b>8 then b:=8;
fArrowWidth:=b;
updateImg;
end;

procedure TRotary.setRoundArrow(bl:boolean);
begin
fRoundArrow:=bl;
updateImg;
end;

function TRotary.event(e:byte;x,y:longInt;key:byte=0):boolean;
begin
result:=inherited event(e,x,y,key);
if result then case e of
EVENT_LDN :begin
if getKeyState(VK_CONTROL)<0 then begin ms:=true;setValue(fInitValue);ms:=false end;
mbX:=x;mbY:=y;mbPos:=fPercent
end;
EVENT_RDN :;
EVENT_LUP :;
EVENT_MMOVE :if fPressed then begin
ms:=true;
setPercent(mbPos+x-mbX+mbY-y);
ms:=false;
if not fRoundedValue then
if (fPercent=0) or (fPercent=100) then begin mbX:=x;mbY:=y;mbPos:=fPercent end;
end;
end;
end;

//--------------------------------------------------------------------------------------------------
//TCustomFader:

constructor TCustomFader.Create(AOwner:TComponent);
begin
started:=false; //is set to true be descendants
inherited Create(AOwner);
if AOwner is TWinControl then parent:=TWinControl(AOwner);
doubleBuffered := true;
fDesignMode := csDesigning in componentState;
controlStyle := [csAcceptsControls,csCaptureMouse,csClickEvents,csOpaque];
color := clWhite;
showHint := false;
useTabKey := false;
tabStop := false;
fBevelWidth := 2;
fInitValue := 0;
ms := false; //manual scroll
fPercent := 0;
fMin := 0;
fMax := $FF;
fRoundedValue := false;
fSpacing := 1;
fColorKnob := $DA7C3F;
cursor := crHandPoint;
end;

destructor TCustomFader.Destroy;
begin
started:=false;
fOnPosition:=nil;
inherited Destroy;
end;

procedure TCustomFader.Resize;//for descendants
begin
inherited Resize;
updateImg;
end;

procedure TCustomFader.updateImg;//for descendants
begin
canvas.brush.color:=color;
canvas.fillrect(rect(0,0,width,height));
Invalidate;
end;

function TCustomFader.event(e:byte;x,y:longInt;key:byte=0):boolean;
begin
result:=true;
case e of
EVENT_CLICK :;//accept
EVENT_LDN :begin setFocus;fPressed:=true end;
EVENT_RDN :begin setFocus;fPressed:=false end;
EVENT_MDN :begin setFocus;fPressed:=false end;
EVENT_LUP :fPressed:=false;//accept
EVENT_MUP :;//accept
EVENT_RUP :;//accept
EVENT_MMOVE :;//accept
else result:=false end;
if assigned(fOnEvent) then fOnEvent(e,x,y,key,self);
end;

procedure TCustomFader.CreateParams(var params:TCreateParams);
begin
inherited CreateParams(Params);
end;

procedure TCustomFader.WMGetDlgCode(var msg:TWmGetDlgCode);
begin
msg.result:=DLGC_WANTALLKEYS or DLGC_WANTARROWS;
if useTabKey then msg.result:=msg.result or DLGC_WANTTAB;
end;

function TCustomFader.screenXY:TPoint;
begin
result:=ClientOrigin;
end;

function TCustomFader.screenRect:TRect;
begin
with result,screenXY do begin
left := x;
top := y;
right := x+clientWidth;
bottom := y+clientHeight;
end;
end;

procedure TCustomFader.WndProc(var msg:TMessage);
begin
inherited;
case msg.Msg of
CM_COLORCHANGED :updateImg;
CM_ENABLEDCHANGED :updateImg;
CM_VISIBLECHANGED :if visible then updateImg;
end;
end;

procedure TCustomFader.MouseMove(shift:TShiftState;x,y:integer);
begin
event(EVENT_MMOVE,x,y);
end;

procedure TCustomFader.MouseDown(button:TMouseButton;shift:TShiftState;x,y:integer);
begin
if fDesignMode then inherited;
if (button<>mbLeft) then event(E_MOUSEDN[button],x,y) else event(EVENT_LDN,x,y);
end;

procedure TCustomFader.MouseUp(button:TMouseButton;shift:TShiftState;x,y:integer);
begin
if fDesignMode then inherited;
event(E_MOUSEUP[button],x,y);
end;

procedure TCustomFader.Click;
begin
inherited Click;
event(EVENT_CLICK,0,0);
end;

procedure TCustomFader.setMin(f:double);
begin
if f<>fMin then fMin:=f else exit;
updateImg;
end;

procedure TCustomFader.SetFocus;
begin
if fDesignMode or not (tabStop and canFocus) then exit;
inherited SetFocus;
end;

procedure TCustomFader.setMax(f:double);
begin
if f<>fMax then fMax:=f else exit;
updateImg;
end;

procedure TCustomFader.setPercent(f:double);
var t:double;
begin
if f<0 then f:=0 else
if f>100 then f:=100;

if fRoundedValue then begin
t:=fMax-fMin; //steps from min to max
f:=mulDiv(100,round(mulDiv(t,f,100)),t);
end;

if f<>fPercent then fPercent:=f else exit;
updateImg;
if assigned(fOnPosition) then fOnPosition(self,ms);
end;

function TCustomFader.getValue:double;
begin
result:=map(fPercent,0,100,fMin,fMax);
if fRoundedValue then result:=round(result);
end;

procedure TCustomFader.setValue(f:double);
begin
if fRoundedValue then f:=round(f);
setPercent(map(f,fMin,fMax,0,100));
end;

function TCustomFader.getValueInt:longInt;
begin
result:=trunc(getValue);
end;

procedure TCustomFader.setValueInt(i:longInt);
begin
setValue(i);
end;

procedure TCustomFader.setRoundedValue(bl:boolean);
begin
fRoundedValue:=bl;
if bl then setValue(round(getValue));
updateImg;
end;

procedure TCustomFader.setSpacing(n:byte);
begin
if n>16 then n:=16;
fSpacing:=n;
reSize;
end;

procedure TCustomFader.setBevelWidth(w:byte);
begin
if w>16 then w:=16;
fBevelWidth:=w;
reSize;
end;

procedure TCustomFader.setColorKnob(cl:TColor);
begin
fColorKnob:=cl;
updateImg;
end;

//..

const
COMPONENT_PAGE = 'mortenbs.com';

procedure Register;
begin
registerComponents(COMPONENT_PAGE, [TFader]);
registerComponents(COMPONENT_PAGE, [TRotary]);
end;

end.

Example

unit Unit1;

interface

uses
Windows, faderRotary, Classes, Graphics, Controls, Forms;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
public
fader1 :TFader;
rotary1 :TRotary;
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
doubleBuffered := true;
fader1 := TFader.Create(self);
fader1.left := 3;
fader1.top := 3;
fader1.width := 120;
fader1.height := 24;
fader1.knobSize := 12;
rotary1 := TRotary.Create(self);
rotary1.left := 3;
rotary1.top := 48;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
fader1.free;
rotary1.free;
end;

end.

Related pages of TFader and TRotary

Delphi programming
Programming
TLedPanel component