Mega Code Archive
Led component
<![CDATA[
Title: Led component
Question: Led component
Answer:
unit RVLed;
interface
uses
SysUtils, Classes, Controls, Windows, Graphics;
type
TRVBorderStyle = (rvbsNone, rvbsFlat, rvbs3D);
TRVSubLed = class(TPersistent)
private
FBmp: TBitmap;
FColor: TColor;
FWidth: Integer;
FFontName: TFontName;
procedure SetColor(const Value: TColor);
procedure SetWidth(const Value: Integer);
procedure SetFontName(const Value: TFontName);
published
property Color: TColor read FColor write SetColor;
property FontName: TFontName read FFontName write SetFontName;
property Width: Integer read FWidth write SetWidth;
end;
TRVLed = class(TGraphicControl)
private
FTransparent: Boolean;
FBorderStyle: TRVBorderStyle;
FLed: TRVSubLed;
FCaption: String;
FGap: Integer;
FAlignment: TAlignment;
procedure SetTransparent(const Value: Boolean);
procedure SetBorderStyle(const Value: TRVBorderStyle);
procedure SetLed(const Value: TRVSubLed);
procedure SetCaption(const Value: String);
procedure SetGap(const Value: Integer);
procedure SetAlignment(const Value: TAlignment);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Alignment: TAlignment read FAlignment write SetAlignment;
property Anchors;
property BorderStyle: TRVBorderStyle read FBorderStyle write SetBorderStyle;
property Caption: String read FCaption write SetCaption;
property Gap: Integer read FGap write SetGap;
property Led: TRVSubLed read FLed write SetLed;
property Transparent: Boolean read FTransparent write SetTransparent;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Rendez-vous', [TRVLed]);
end;
{ TRVLed }
constructor TRVLed.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
//Create the subclass
FLed := TRVSubLed.Create;
FLed.FFontName := Font.Name;
FLed.FColor := clLime;
FLed.FWidth := 16;
FLed.FBmp := TBitmap.Create;
FLed.FBmp.Transparent := True;
//Set default values
FTransparent := False;
FBorderStyle := rvbs3D;
FAlignment := taLeftJustify;
FGap := 2;
end;
destructor TRVLed.Destroy;
begin
FLed.FBmp.Free;
FLed.Free;
inherited Destroy;
end;
procedure TRVLed.Paint;
var
R: TRect;
RGBPal: array[0..2] of Byte;
BkColor: TColor;
XPos: Integer;
X: Integer;
Y: Integer;
I: Integer;
J: Integer;
Bmp: TBitmap;
Temp: String;
begin
R := ClientRect;
//Lock the refresh medthod
LockWindowUpdate(Canvas.Handle);
//Draw a frame around the component if needed
if FBorderStyle = rvbsFlat then
begin
Canvas.Brush.Color := clBlack;
Canvas.FrameRect(R);
InflateRect(R, -1, -1);
end
else if FBorderStyle = rvbs3D then
begin
Canvas.Brush.Color := clBtnHighlight;
Canvas.FrameRect(R);
Canvas.Pen.Color := clBtnShadow;
Canvas.MoveTo(R.Left, R.Bottom);
Canvas.LineTo(R.Left, R.Top);
Canvas.LineTo(R.Right, R.Top);
InflateRect(R, -1, -1);
end;
//Fill client area if needed
if not FTransparent then
begin
Canvas.Brush.Color := clBlack;
Canvas.FillRect(R);
InflateRect(R, FGap * -1, FGap * -1);
end;
//Get the disable color of the led
BkColor := ColorToRGB(FLed.FColor);
RGBPal[0] := GetRValue(BkColor);
RGBPal[1] := GetGValue(BkColor);
RGBPal[2] := GetBValue(BkColor);
if RGBPal[0] 0 then RGBPal[0] := RGBPal[0] - 128;
if RGBPal[1] 0 then RGBPal[1] := RGBPal[1] - 128;
if RGBPal[2] 0 then RGBPal[2] := RGBPal[2] - 128;
BkColor := RGB(RGBPal[0], RGBPal[1], RGBPal[2]);
//Create a temporary bitmap pixels by pixels for the background of the led
FLed.FBmp.Height := (R.Bottom - R.Top);
FLed.FBmp.Width := FLed.FWidth;
for Y := 1 to FLed.FBmp.Height do
begin
if not Odd(Y) then continue;
for X := 1 to FLed.FBmp.Width do
begin
if not Odd(X) then continue;
FLed.FBmp.Canvas.Pixels[X, Y] := BkColor;
end;
end;
//Set the string regarding to the Alignment property
if FAlignment = taRightJustify then
begin
J := (R.Right - R.Left) div (FLed.FWidth + FGap);
Temp := Format('%*.*s', [J, J, FCaption]);
end
else if FAlignment = taCenter then
begin
J := (R.Right - R.Left) div (FLed.FWidth + FGap);
J := (J + Length(FCaption)) div 2;
Temp := Format('%*.*s', [J, J, FCaption]);
end
else
Temp := FCaption;
//Display
XPos := R.Left;
I := 1;
repeat
Canvas.Draw(XPos, R.Top, FLed.FBmp);
if Length(Temp) = I then
begin
//Creating a temporary bitmap to put a caracter on it
Bmp := TBitmap.Create;
Bmp.Transparent := True;
Bmp.Canvas.Font.Color := FLed.Color;
Bmp.Canvas.Font.Name := FLed.FFontName;
Bmp.Canvas.Font.Style := [];
Bmp.Width := Bmp.Canvas.TextWidth(Temp[I]);
Bmp.Height := Bmp.Canvas.TextHeight(Temp[I]);
Bmp.Canvas.TextOut(0, 0, Temp[I]);
//Put the temporary bitmap over the led bitmap and stretch it
Canvas.StretchDraw(Rect(XPos, R.Top, XPos + FLed.FWidth, R.Bottom), Bmp);
Bmp.Free;
end;
XPos := XPos + FGap + FLed.FWidth;
I := I + 1;
until XPos = R.Right;
//Unlock the refresh method
LockWindowUpdate(0);
end;
procedure TRVLed.SetAlignment(const Value: TAlignment);
begin
if FAlignment Value then
begin
FAlignment := Value;
Invalidate;
end;
end;
procedure TRVLed.SetBorderStyle(const Value: TRVBorderStyle);
begin
if FBorderStyle Value then
begin
FBorderStyle := Value;
Invalidate;
end;
end;
procedure TRVLed.SetCaption(const Value: String);
begin
if FCaption Value then
begin
FCaption := Value;
Invalidate;
end;
end;
procedure TRVLed.SetGap(const Value: Integer);
begin
if FGap Value then
begin
FGap := Value;
Invalidate;
end;
end;
procedure TRVLed.SetLed(const Value: TRVSubLed);
begin
if FLed Value then
begin
FLed := Value;
Invalidate;
end;
end;
procedure TRVLed.SetTransparent(const Value: Boolean);
begin
if FTransparent Value then
begin
FTransparent := Value;
Invalidate;
end;
end;
{ TRVSubLed }
procedure TRVSubLed.SetColor(const Value: TColor);
begin
if FColor Value then
begin
FColor := Value;
end;
end;
procedure TRVSubLed.SetFontName(const Value: TFontName);
begin
if FFontName Value then
begin
FFontName := Value;
end;
end;
procedure TRVSubLed.SetWidth(const Value: Integer);
begin
if FWidth Value then
begin
FWidth := Value;
end;
end;
end.
]]>