Gallery
Software
Music
Programming
Archive
Wednesday, Jan 16 Week 3
TLedPanel component for Delphi is simple and easy to use.


A small demo project is included in the archive.

tledpanel-example.zip
(204.78 Kb)
, Downloads: 498

unit ledPanel;

interface

//TLedPanel v1.0, mortenbs.com
//Last updated: 2010-05-16

uses
windows,classes,controls,graphics;

{$R ledPanel.dcr}

type
ptr=pointer;
lInt=longInt;
str=ansiString;
tLedMode=(lmMulti,lmSingle,lmSingleForced);
tTextMode=(tmAutoNumb,tmDisabled,tmManual,tmCommon);
pPtrList=^tPtrList;
tPtrList=array[0..MAXINT div 16-1] of ptr;
tSimpleEvent=procedure of object;
//-----------------------------|----------------|----------------------|----------------------------
tLed=class public
text :str;
state :boolean;
colorBgOn,colorBgOff :tColor;
colorFontOn,colorFontOff :tColor;
txtW,txtH,x1,y1,x2,y2 :lInt;
end;
//-----------------------------|----------------|----------------------|----------------------------
tLeds=class
procedure clear;
function validId(id:lInt):boolean;
function add(aLed:tLed):lInt;
procedure delete(id:lInt);
private
fCount,fCapacity :lInt;
procedure setCapacity(i:lInt);
procedure setCount(i:lInt);
procedure grow;
public
fList :pPtrList;
destructor destroy;override;
property count :lInt read fCount write setCount;
end;
//-----------------------------|----------------|----------------------|----------------------------
tLedPanel=class(tCustomControl)
function isSingleLed(b:byte):boolean; //In single-led mode this is the current LED
function findLed(x,y:lInt):lInt; //Position to led-ID
function getLedState(id:byte):boolean; //Get led state (any mode)
procedure setLedState(id:lInt;bl:boolean); //Set led state (any mode)
procedure invLedState(id:byte); //Inverse led state (multi)
procedure updateLedColors;
private
fHintMode :tTextMode; //Hint mode
fLedMode :tLedMode; //Led Mode (multi/single/singleForced)
fManualText :tStringList; //Led text (manual text mode)
fTextMode :tTextMode; //Text mode (autoNumb,disabled,manual,common)
fCommonText :str; //Common text for all leds (common text mode)
fFontSize,fLedSize :byte; //Font-size, LED-size
fLedCount,fSingleLed :byte; //LED-Count, Single LED id (single/singleForced)
fFontName :tFontName; //Font name
fUseMouse :boolean; //Enable mouse support
fVertical,fAutoSize,started :boolean; //Vertical panel, Auto size
fColorBgOn,fColorBgOff :tColor; //Default colors (LEDs background)
fColorFontOn,fColorFontOff :tColor; //Default colors (LEDs font)
fColorBorder :tColor; //Panel borders color
fOnStateChange :tSimpleEvent; //Event when a LED-state is changed
using_text,using_multi :boolean; //Internal use
invert_from :boolean; //Internal use
mouse_led,last_mouse_led :lInt; //Internal use
procedure setColorBorder(aColor:tColor);
function getLedText(id:lInt):str;
function getFirstLedState:boolean;
procedure setFirstLedState(bl:boolean);
procedure setVertical(bl:boolean);
procedure setAutoSize(bl:boolean);reintroduce;
procedure setColorBgOff(aColor:tColor);
procedure setColorBgOn(aColor:tColor);
procedure setColorFontOff(aColor:tColor);
procedure setColorFontOn(aColor:tColor);
procedure setCommonText(s:str);
procedure setFontName(s:tFontName);
procedure setFontSize(b:byte);
procedure setLedCount(b:byte);
procedure setSingleLed(b:byte);
procedure setLedSize(aSize:byte);
procedure setManualText(sl:tStringList);
procedure setTextMode(aMode:tTextMode);
procedure setLedMode(lm:tLedMode);
procedure setHintMode(lm:tTextMode);
protected
procedure reSize;override;
procedure paint;override;
procedure mouseDown(button:tMouseButton;shift:tShiftState;x,y:integer);override;
procedure mouseMove(shift:tShiftState;x,y:integer);override;
public
leds :tLeds; //Leds list
constructor create(aOwner:tComponent);override;
destructor destroy;override;
procedure rePaint;override;
procedure notifyStateChanged;
published
property align;
property cursor;
property showHint;
property visible;
property popUpMenu;
property autoSize :boolean read fAutoSize write setAutoSize;
property commonText :str read fCommonText write setCommonText;
property colorBorder :tColor read fColorBorder write setColorBorder;
property colorBgOff :tColor read fColorBgOff write setColorBgOff;
property colorBgOn :tColor read fColorBgOn write setColorBgOn;
property colorFontOff :tColor read fColorFontOff write setColorFontOff;
property colorFontOn :tColor read fColorFontOn write setColorFontOn;
property firstLed :boolean read getFirstLedState write setFirstLedState;
property fontName :tFontName read fFontName write setFontName;
property fontSize :byte read fFontSize write setFontSize;
property ledCount :byte read fLedCount write setLedCount;
property ledMode :tLedMode read fLedMode write setLedMode;
property ledSize :byte read fLedSize write setLedSize;
property manualText :tStringList read fManualText write setManualText;
property singleLed :byte read fSingleLed write setSingleLed;
property textMode :tTextMode read fTextMode write setTextMode;
property hintMode :tTextMode read fHintMode write setHintMode;
property vertical :boolean read fVertical write setVertical;
property useMouse :boolean read fUseMouse write fUseMouse;
property onStateChange :tSimpleEvent read fOnStateChange write fOnStateChange;
property onMouseMove;
property onMouseDown;
property onMouseUp;
end;
//-----------------------------|----------------|----------------------|----------------------------

function allIsOn(aLeds:tLedPanel):boolean;
function allIsOff(aLeds:tLedPanel):boolean;

//...
procedure Register;

implementation

uses
sysUtils,forms;

function allIsOn(aLeds:tLedPanel):boolean;
var i:lInt;
begin result:=false;if aLeds.fLedMode<>lmMulti then exit;
for i:=0 to aLeds.leds.count-1 do if not tLed(aLeds.leds.fList^[i]).state then exit;result:=true
end;

function allIsOff(aLeds:tLedPanel):boolean;
var i:lInt;
begin result:=false;if aLeds.fLedMode<>lmMulti then exit;
for i:=0 to aLeds.leds.count-1 do if tLed(aLeds.leds.fList^[i]).state then exit;result:=true
end;

//------------------------------------------------------------------------------------------------
//tLeds:

destructor tLeds.destroy;
begin clear;inherited destroy end;

function tLeds.validId(id:lInt):boolean;
begin result:=(id>-1) and (id<fCount) end;

procedure tLeds.clear;
begin if fCount=0 then exit;
while fCount>0 do delete(fCount-1);
setCount(0);setCapacity(0)
end;

function tLeds.add(aLed:tLed):lInt;
begin result:=fCount;if result=fCapacity then grow;
fList^[result]:=ptr(aLed);inc(fCount)
end;

procedure tLeds.delete(id:lInt);
begin
if fList^[id]<>nil then begin tLed(fList^[id]).free;fList^[id]:=nil end;
dec(fCount);if id<fCount then system.move(fList^[id+1],fList^[id],(fCount-id)*sizeOf(ptr))
end;

procedure tLeds.setCount(i:lInt);
var c:lInt;
begin
if i<0 then i:=0 else if i>255 then i:=255;
if i>fCapacity then setCapacity(i);
if i>fCount then fillChar(fList^[fCount],(i-fCount)*sizeOf(ptr),0) else
for c:=fCount-1 downto i do delete(c);fCount:=i
end;

procedure tLeds.grow;var i:lInt;
begin
if fCapacity>64 then i:=fCapacity div 4 else
if fCapacity>8 then i:=16 else i:=4;
setCapacity(fCapacity+i)
end;

procedure tLeds.setCapacity(i:lInt);
begin
if i=fCapacity then exit;
if i<fCount then i:=fCount;if i>255 then i:=255;
reAllocMem(fList,i*sizeOf(ptr));fCapacity:=i
end;

//------------------------------------------------------------------------------------------------
//tLedPanel:

constructor tLedPanel.create(aOwner:tComponent);//override;
begin started:=false;
if not assigned(fManualText) then fManualText:=tStringList.create;
inherited create(aOwner);parent:=(aOwner as tWinControl);
controlStyle:=[csAcceptsControls,csCaptureMouse,csClickEvents,csSetCaption];
doubleBuffered:=true;tabStop:=false;useDockManager:=true;
fFontName:='Tahoma';fFontSize:=8;fSingleLed:=0;fLedCount:=5;
fVertical:=false;fAutoSize:=true;fLedSize:=14;fUseMouse:=true;
fColorBgOn:=$0060DD60;fColorBgOff:=$001C621C;
fColorFontOn:=$00000000;fColorFontOff:=$00FFFFFF;fColorBorder:=$00000000;
using_text:=false;using_multi:=false;invert_from:=false;mouse_led:=-1;last_mouse_led:=-1;

leds:=tLeds.create;
if leds.fCount=0 then begin fLedMode:=lmMulti;fTextMode:=tmAutoNumb;
setHintMode(tmAutoNumb);if not fVertical then height:=13 else if width<1 then width:=fLedSize
end;

started:=true;
setLedCount(fLedCount)
end;

destructor tLedPanel.destroy;begin started:=false;leds.free;fManualText.free;inherited destroy end;
procedure tLedPanel.notifyStateChanged;begin invalidate;if assigned(fOnStateChange) then fOnStateChange end;
procedure tLedPanel.rePaint;begin invalidate end;
procedure tLedPanel.setFontName(s:tFontName);begin fFontName:=s;reSize end;
procedure tLedPanel.setFontSize(b:byte);begin fFontSize:=b;reSize end;
procedure tLedPanel.setHintMode(lm:tTextMode);begin fHintMode:=lm;inherited showHint:=lm<>tmDisabled end;
function tLedPanel.isSingleLed(b:byte):boolean;begin result:=fSingleLed=b end;
procedure tLedPanel.setCommonText(s:str);begin fCommonText:=s;reSize end;
procedure tLedPanel.setColorBorder(aColor:tColor);begin fColorBorder:=aColor;reSize end;
procedure tLedPanel.setColorBgOff(aColor:tColor);begin fColorBgOff:=aColor;color:=aColor;updateLedColors end;
procedure tLedPanel.setColorBgOn(aColor:tColor);begin fColorBgOn:=aColor;updateLedColors end;
procedure tLedPanel.setColorFontOff(aColor:tColor);begin fColorFontOff:=aColor;updateLedColors end;
procedure tLedPanel.setColorFontOn(aColor:tColor);begin fColorFontOn:=aColor;updateLedColors end;
procedure tLedPanel.setAutoSize(bl:boolean);begin fAutoSize:=bl;reSize end;
procedure tLedPanel.invLedState(id:byte);begin setLedState(id,not getLedState(id)) end;
procedure tLedPanel.setLedSize(aSize:byte);begin fLedSize:=aSize;reSize end;
procedure tLedPanel.setTextMode(aMode:tTextMode);begin fTextMode:=aMode;reSize end;
procedure tLedPanel.setManualText(sl:tStringList);begin fManualText.text:=sl.text;reSize end;
procedure tLedPanel.setFirstLedState(bl:boolean);begin setLedState(1,bl) end;

function tLedPanel.getLedState(id:byte):boolean;
begin result:=leds.validId(id-1) and tLed(leds.fList^[id-1]).state end;

function tLedPanel.getFirstLedState:boolean;
begin if fLedMode=lmMulti then result:=getLedState(1) else result:=fSingleLed=1 end;

function tLedPanel.getLedText(id:lInt):str;
begin result:='';
case fTextMode of
tmAutoNumb:result:=intToStr(id+1);
tmCommon:result:=fCommonText;
tmManual:if (id>-1) and (id<fManualText.count) then result:=fManualText.strings[id]
end
end;

procedure tLedPanel.setVertical(bl:boolean);
var i:lInt;
begin if bl=fVertical then exit;
fVertical:=bl;i:=width;height:=width;width:=i;reSize
end;

procedure tLedPanel.updateLedColors;
var i:lInt;
begin
for i:=0 to leds.count-1 do with tLed(leds.fList^[i]) do begin
colorBgOn:=self.fColorBgOn;
colorBgOff:=self.fColorBgOff;
colorFontOn:=self.fColorFontOn;
colorFontOff:=self.fColorFontOff;
end;reSize
end;

procedure tLedPanel.reSize;
var i,tW,tH,stPos,amount:lInt;
begin if not started then exit;stPos:=0;tW:=0;tH:=0;
using_text:=fTextMode<>tmDisabled;using_multi:=fLedMode=lmMulti;
canvas.font.name:=fFontName;canvas.font.size:=fFontSize;

for i:=0 to leds.fCount-1 do with tLed(leds.fList^[i]) do begin
text:=getLedText(i);with canvas.textExtent(text) do begin txtW:=cX;txtH:=cY;tW:=cX;tH:=cY end;
if fVertical then begin x1:=0;x2:=self.width;y1:=stPos;
if fAutoSize then y2:=y1+txtH+6 else y2:=y1+fLedSize+2;amount:=y2-y1
end else begin y1:=0;y2:=self.height;x1:=stPos;
if fAutoSize then x2:=stPos+txtW+6 else x2:=x1+fLedSize+2;amount:=x2-x1
end;inc(stPos,amount-1)
end;

if stPos>0 then if fVertical then height:=stPos+1 else width:=stPos+1;
if fAutoSize then if fVertical then width:=tW+1 else height:=tH+1;
invalidate
end;

procedure tLedPanel.paint;//override;
var i:lInt;aState:boolean;
begin if not (started and visible) then exit;
with canvas,leds do for i:=0 to fCount-1 do with tLed(fList^[i]) do begin
if using_multi then aState:=state else aState:=i=fSingleLed-1;
brush.style:=bsSolid;pen.color:=fColorBorder;
if aState then brush.color:=colorBgOn else brush.color:=colorBgOff;
rectangle(x1,y1,x2,y2);if (text='') or not using_text then continue;
if aState then font.color:=colorFontOn else font.color:=colorFontOff;brush.style:=bsClear;
textOut(x1+trunc(((x2-x1)/2)-(txtW/2)),y1+trunc(((y2-y1)/2)-(txtH/2)),text);
end
end;

procedure tLedPanel.setLedCount(b:byte);
var aLed:tLed;
begin
if b<1 then b:=1;fLedCount:=b;
while leds.count>b do leds.delete(leds.fCount-1);
while leds.count<b do begin
aLed:=tLed.create;aLed.state:=false;aLed.text:='';
aLed.colorBgOn:=fColorBgOn;aLed.colorBgOff:=fColorBgOff;
aLed.colorFontOn:=fColorFontOn;aLed.colorFontOff:=fColorFontOff;
leds.add(aLed)
end;reSize
end;

procedure tLedPanel.setLedState(id:lInt;bl:boolean);
var doNotify:boolean;
begin if fLedMode<>lmMulti then begin setSingleLed(id);exit end;doNotify:=false;
if leds.validId(id-1) then with tLed(leds.fList^[id-1]) do begin doNotify:=state<>bl;state:=bl end;
if doNotify then notifyStateChanged
end;

function tLedPanel.findLed(x,y:lInt):lInt;
var i:lInt;
begin for i:=0 to leds.fCount-1 do with tLed(leds.fList^[i]) do
if (x>=x1) and (x<=x2) and (y>=y1) and (y<=y2) then begin result:=i;exit end;result:=-1
end;

procedure tLedPanel.mouseDown(button:tMouseButton;shift:tShiftState;x,y:integer);//override;
begin if (button<>mbLeft) or not fUseMouse then exit;
if fLedMode=lmMulti then setLedState(mouse_led,not invert_from) else
if (fLedMode=lmSingleForced) and isSingleLed(0) then setSingleLed(1) else setSingleLed(mouse_led);
if assigned(onMouseDown) then onMouseDown(self,button,shift,x,y)
end;

procedure tLedPanel.mouseMove(shift:tShiftState;x,y:integer);//override;
var s:str;p:tPoint;
begin
if fVertical then mouse_led:=findLed(width,y)+1 else mouse_led:=findLed(x,height)+1;
if getKeyState(VK_LBUTTON)>=0 then begin
if fLedMode=lmMulti then invert_from:=getLedState(mouse_led) else invert_from:=isSingleLed(mouse_led)
end else if last_mouse_led<>mouse_led then mouseDown(mbLeft,[],x,y);
last_mouse_led:=mouse_led;s:=hint;
case fHintMode of
tmCommon:hint:=fCommonText;
tmAutoNumb:hint:='Led: '+intToStr(mouse_led);
tmManual:if (mouse_led>-1) and (mouse_led<fManualText.count) then hint:=fManualText[mouse_led] else hint:='-'
end;
if s<>hint then with application do begin cancelHint;getCursorPos(p);activateHint(p) end;
if assigned(onMouseMove) then onMouseMove(self,shift,x,y)
end;

procedure tLedPanel.setSingleLed(b:byte);
var v:byte;
begin
if fLedMode=lmSingleForced then v:=1 else v:=0;
if (b=fSingleLed) or (b<v) or (b>fLedCount) then exit;
fSingleLed:=b;notifyStateChanged
end;

procedure tLedPanel.setLedMode(lm:tLedMode);
begin fLedMode:=lm;
if (fLedMode=lmSingleForced) and isSingleLed(0) then setSingleLed(1) else invalidate
end;

//...
procedure Register;
begin
registerComponents('Standard', [tLedPanel]);
end;

end.

unit Unit1;

interface

uses
windows,ledPanel,classes,controls,graphics,forms, stdCtrls, extCtrls;

type
TForm1 = class(TForm)
led1: tLedPanel;
led6: tLedPanel;
led2: tLedPanel;
led3: tLedPanel;
led4: tLedPanel;
led5: tLedPanel;
Label1: TLabel;
ledOptions: tLedPanel;
Timer1: TTimer;
vu1L: tLedPanel;
vu1R: tLedPanel;
vu2L: tLedPanel;
vu2R: tLedPanel;
procedure ledOptionsStateChange;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
fStep:byte;
mode1,mode2,mode3,mode4,mode5,mode6:boolean;
public
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin doubleBuffered:=true;randomize;
ledOptions.setLedState(1,true);
ledOptions.setLedState(2,true);
ledOptions.onStateChange:=ledOptionsStateChange;
ledOptionsStateChange;
mode1:=true;mode2:=true;mode3:=true;mode4:=true;mode5:=true;
vu1L.width:=37;vu1R.width:=37;vu2L.width:=37;vu2R.width:=37;
Timer1.interval:=50;
Timer1.enabled:=true;
end;

procedure TForm1.ledOptionsStateChange;
var blA,blB:boolean;
begin
blA:=ledOptions.getLedState(1);Timer1.enabled:=blA;
blB:=ledOptions.getLedState(2);
led1.useMouse:=blB;
led2.useMouse:=blB;
led3.useMouse:=blB;
led4.useMouse:=blB;
led5.useMouse:=blB;
led6.useMouse:=blB;
if not blA then begin mode1:=false;mode2:=false;mode3:=false;mode4:=false;mode5:=false end;
end;

function maybe:boolean;
begin result:=random(1+1)=1 end;

function randomRange(aMin,aMax:lInt):lInt;
begin result:=random(aMax-(aMin-1))+aMin end;

function randomColor(aMinR,aMaxR,aMinG,aMaxG,aMinB,aMaxB:byte):tColor;
begin
result:=(random(aMaxR-(aMinR-1))+aMinR)
or ((random(aMaxG-(aMinG-1))+aMinG) shl 8)
or ((random(aMaxB-(aMinB-1))+aMinB) shl 16)
end;

function manageRandomLeds(aLeds:tLedPanel;var aMode:boolean):lInt;
var i,c,v:lInt;bl:boolean;
begin result:=-1;c:=0;
for i:=0 to aLeds.leds.count-1 do if tLed(aLeds.leds.fList^[i]).state<>aMode then inc(c);
if c>0 then v:=randomRange(1,c) else exit;c:=0;
for i:=0 to aLeds.leds.count-1 do with tLed(aLeds.leds.fList^[i]) do begin
if state<>aMode then inc(c);if c=v then begin state:=aMode;aLeds.rePaint;break end
end;
if aMode then bl:=allIsOn(aLeds) else bl:=allIsOff(aLeds);
if bl then aMode:=not aMode;
end;

procedure manageLedPos(aLeds:tLedPanel;var aMode:boolean);
var id:lInt;bl:boolean;
begin
id:=aLeds.singleLed;
if aMode then inc(id) else dec(id);
if aMode then bl:=id>aLeds.ledCount else bl:=id<1;
if bl then aMode:=not aMode;
aLeds.singleLed:=id;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var i,v:lInt;
begin
if maybe then manageRandomLeds(led1,mode1);
if maybe then manageRandomLeds(led2,mode2);
manageLedPos(led3,mode3);
manageLedPos(led4,mode4);
manageLedPos(led5,mode5);

manageLedPos(vu1L,mode6);vu2L.setLedState(vu2L.ledCount,true);
manageLedPos(vu1R,mode6);vu2R.setLedState(vu2R.ledCount,true);

v:=vu1L.singleLed;for i:=1 to vu2L.leds.count do tLed(vu2L.leds.fList[i-1]).state:=i>=v;
v:=vu1R.singleLed;for i:=1 to vu2R.leds.count do tLed(vu2R.leds.fList[i-1]).state:=i>=v;
vu2L.rePaint;vu2R.rePaint;

inc(fStep);
if fStep>49 then begin fStep:=0;
vu1L.singleLed:=randomRange(1,vu1L.ledCount);
vu1R.singleLed:=randomRange(1,vu1R.ledCount);
end;
end;

end.

Related pages of TLedPanel component

TFader and TRotary
Delphi programming
Programming