Gallery
Software
Music
Programming
Archive
Friday, Jul 19 Week 29

TFader and TRotary

Simple fader and rotary component for Delphi.



Download example

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

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;
//--------------------------|---------------------|-----------------------|-------------------------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 resultaMaxB 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:=(dX0) and (dY0);
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$FF then g:=$FF else if g$FF then b:=$FF else if b0 then with bg do begin
inc(x1,sp);dec(x2,sp);
inc(y1,sp);dec(y2,sp);
pen.width:=1;

while sz0 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=height) then continue;//y safety
x:=cX+round(rad*s);if (x=width) then continue;//x safety
a:=$FF*i div v+h;
m:=a*2;if a0 then pen.color:=clBrd else pen.color:=clKnob;
windows.roundRect(handle,x1,y1,x2,y2,x2,y2);

if (bvl0) and asRadius(x1+brd,y1+brd,x2-brd,y2-brd,cX,cY,rX,rY) then begin
if rY0) 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 lineSz0 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 brd0 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 bvl0 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 n10 then n:=10;
fLineSize:=n;
reSize
end;

procedure TFader.setColorLine(cl:TColor);
begin
fColorLine:=cl;
if fLineSize0 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)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)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 ffMin 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 ffMax then fMax:=f else exit;
updateImg;
end;

procedure TCustomFader.setPercent(f:double);
var t:double;
begin
if f100 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 ffPercent 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