| a Delphi component for color selection |
 |
Introduction
The Delphi programming environments already contains a dialog form for
color selection.
In some cases however, a simple component, not a pop-up form, for the selection of colors is needed.
This component may also be integrated in complex, home built, dialog forms.
This article describes such a simple component.
At the end, the complete source code is listed as well.
How the component may look
 |
| 8 color mode, square = 20*20 pixels |
 |
| 64 color mode, square = 20*20 pixels |
 |
| 512 color mode, square = 10*10 pixels |
Ancestor Class
The ancestor class is the TGraphicControl component, which is also the ancestor
of the Tpaintbox component.
Basically, the davColorBox is a modified paintbox.
Component Properties
- direction
- cbHor .............horizontal position
- cbVert ............ vertical position
- colorDepth
- cb8 .............1 bit per color, 8 selectable colors
- cb64............2 bits per color, 64 selectable colors
- cb512..........3 bits per color, 512 selectable colors
- border
- 0 .. 10 ............number of pixels of edges
- borderlight
- 32 bit integer ..............color of top and left edges
- borderdark
- 32 bit integer ...............color of bottom and right edges
-csquare
- byte, value 5 .. 40..........edge length of each colored square in rectangle
Component Methods
Component Events
- onSelect .............provides selected color
OnSelect is derived from the Mouse_Up event.
Component Application
When a mouse_up event occurs on the davColorBox component,
an OnSelect event is received.
procedure Tform1.selcolor(sender : TObject; color : LongInt);
begin
//.............color is the selected color
end;
Remarks
The width and height properties are recalculated by the component,
depending on the colordepth and Csquare values selected.
Within the component, a color is represented by a sequential number in the range 0 .. 511
in the case of 512 color mode.
From this number, the position in the rectangle is calculated for display.
Also the 32 bit Windows color is calculated from this value.
This 32 bit, true color, value is returned at the Onselect event.
Source Code
unit davColorBox;
{color picker component
supply rectangle with selectable colors
properties:
- direction : cbHor, cbVert for horizontal or vertical orientation
- colordepth : cb8, cb64 , cb512 for amount of colors
- Csquare : 5 .. 40, edge of each colored square
- border : 0 .. 10 , the width of the border
- borderlight : color of left and top of border
- borderdark : color of bottom and right side of border
methods:
- create
events:
- OnSelect : mouse-up over a color supplies selected color
}
interface
uses windows,controls,classes;
type TcolorDepth = (cb8,cb64,cb512);
Tcolorboxdir = (cbHor,cbVert);
TColorSelect = procedure(sender : TObject; color : LongInt) of object;
TColorSquare = record
x1 : integer;
y1 : integer;
color : LongInt;
end;
TdavColorBox = class(TGraphicControl)
private
FColorDepth : TColorDepth;
FDirection : Tcolorboxdir;
FColor : LongInt;
FOnSelect : TColorSelect;
Fx : Integer;
Fy : integer;
FBorderwidth: byte;
FBorderlight: LongInt;
FBorderdark : LongInt;
FCsquare : byte;
procedure setDirection(cbDir : TcolorBoxdir);
procedure setColorDepth(cbDepth : TColorDepth);
procedure setDimensions;
function number2color(w : word) : TColorSquare;
protected
procedure paint; override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure setSquare(edge : byte);
procedure setBorderwidth(w : byte);
procedure setBorderlight(c : longInt);
procedure setBorderdark(c : longInt);
procedure select(sender : TObject; selcolor : LongInt);
public
constructor create(AOwner:TComponent); override;
published
property OnSelect : TcolorSelect read FOnSelect write FOnSelect;
property direction: TColorboxdir read FDirection write setDirection default cbHor;
property colordepth: Tcolordepth read Fcolordepth write setcolordepth default cb512;
property Csquare : byte read FCsquare write setSquare default 10;
property border : byte read Fborderwidth write setborderwidth default 2;
property borderlight : longInt read Fborderlight write setborderLight default $ffffff;
property borderdark : LongInt read Fborderdark write setBorderdark default $0;
property visible;
property enabled;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('system',[TdavColorBox]);
end;
procedure TdavColorBox.setDimensions;
const dimlist : array[cb8..cb512] of byte = (2,4,8);
var xx,yy : integer;
begin
yy := dimlist[FcolorDepth]*FCsquare;
xx := yy * dimlist[FColorDepth] + 2*border + 1;
yy := yy + 2*border + 1;
if Fdirection = cbHor then
begin
width := xx; height := yy;
end
else
begin
height := xx; width := yy;
end;
end;
constructor TdavColorBox.create(AOwner: TComponent);
begin
inherited create(Aowner);
FCSquare := 10;
FBorderwidth := 4;
FColorDepth := cb512;
FDirection := cbHor;
FBorderLight := $ffffff;
FBorderdark := $0;
FColor := $0;
setdimensions;
end;
procedure TdavColorBox.setdirection(cbdir : Tcolorboxdir);
begin
Fdirection := cbdir;
setdimensions;
end;
procedure TdavColorbox.setColorDepth(cbdepth : TColorDepth);
begin
FColorDepth := cbdepth;
setSquare(FCSquare);
setdimensions;
end;
function TdavColorBox.number2color(w : word) : TColorSquare;
var r,g,b : byte;
begin
case ColorDepth of
cb8 : begin
r := w and $1;
g := (w shr 1) and 1;
b := (w shr 2) and $1;
result.x1 := border + (r + 2*g) * FCSquare;
result.y1 := border + b * FCSquare;
if r > 0 then r := $ff;
if g > 0 then g := $ff;
if b > 0 then b := $ff;
end;
cb64 : begin
r := (w and $3);
g := (w shr 2) and $3;
b := (w shr 4) and $3;
result.x1 := border + (r + 4*g) * FCSquare;
result.y1 := border + b * FCSquare;
r := r shl 6;
g := g shl 6;
b := b shl 6;
if r > 0 then r := r + $3f;
if g > 0 then g := g + $3f;
if b > 0 then b := b + $3f;
end;
cb512 : begin
r := (w and $7);
g := (w shr 3) and $7;
b := (w shr 6) and $7;
result.x1 := border + (r + 8*g) * FCSquare;
result.y1 := border + b * FCSquare;
r := r shl 5;
g := g shl 5;
b := b shl 5;
if r > 0 then r := r + $1f;
if g > 0 then g := g + $1f;
if b > 0 then b := b + $1f;
end;
end;//case
result.color := RGB(r,g,b);
end;
procedure TdavColorBox.Paint;
const Cmaxcolor : array[cb8..cb512] of word = (7,63,511);
var h,i,x1,y1 : integer;
cs : TColorSquare;
begin
with self do
with canvas do
begin
pen.color := $0;
pen.width := 1;
for i := 0 to border-1 do //borderpaint
begin
pen.color := Fborderlight;
moveto(width-1-i,i);
lineto(i,i);
lineto(i,height-1-i);
pen.color := FborderDark;
lineto(width-1-i,height-1-i);
lineto(width-1-i,i);
end;
//--
for i := 0 to Cmaxcolor[FColorDepth] do
begin
cs := number2color(i);
if FDirection = cbVert then //trade x,y positions for vertical
begin
h := cs.x1; cs.x1 := cs.y1; cs.y1 := h;
end;
brush.color := cs.color;
fillrect(rect(cs.x1,cs.y1,cs.x1+FCSquare,cs.y1+FCSquare));
end;//for i
//--
pen.color := $0;
for i := 0 to ((width-2*border) div FCSquare) do //sep. lines
begin
x1 := border + i * FCSquare;
moveto(x1,border);
lineto(x1,height - border);
end;
for i := 0 to ((height-2*border) div FCSquare) do
begin
y1 := border+ i * FCSquare;
moveto(border,y1);
lineto(width-border,y1);
end;
end;
end;
procedure TdavColorBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var h,v,temp : byte;
colornumber : word;
begin
if (x > Fborderwidth) and (x < width-Fborderwidth-1)
and (y > Fborderwidth) and (y < height-Fborderwidth-1) then
begin
h := (x - Fborderwidth) div FCsquare;
v := (y - Fborderwidth) div FCSquare;
end
else exit;
//--
if FDirection = cbVert then
begin
temp := h; h := v; v:= temp;
end;
case FColorDepth of
cb8 : colornumber := h + v * 4;
cb64 : colornumber := h + v * 16;
cb512 : colornumber := h + v * 64;
end;
Fcolor := number2color(colornumber).color;
if assigned(FOnSelect) then FonSelect(self,FColor);
end;
procedure TdavColorBox.Select(sender : TObject; selcolor : LongInt);
begin
if assigned(FOnSelect) then FonSelect(self,Fcolor);
end;
procedure TDavColorBox.setSquare(edge : byte);
begin
case FColorDepth of
cb8 : if edge > 40 then edge := 40;
cb64 : if edge > 20 then edge := 20;
cb512 : if edge > 10 then edge := 10;
end;
if edge < 5 then edge := 5;
FCSquare := edge;
setdimensions;
end;
procedure TdavColorBox.setBorderwidth(w : byte);
begin
if w > 10 then w := 10;
FBorderwidth := w;
setdimensions;
end;
procedure TdavColorBox.setBorderlight(c : longInt);
begin
FBorderlight := c;
paint;
end;
procedure TdavColorBox.setBorderdark(c : longInt);
begin
FBorderdark := c;
paint;
end;
end.
