Contributor: MARTIJN TONIES
{
After I got the new Swag-snippets and saw how to make components for
Delphi, I just made this one for fun.
You all still remember Knight Rider with his car, KITT... Well, at the
front the car had a scanner... I made it as a component...
All properties are as obvious as can be (I think) so that shouldn't be a
problem. Just install it as normal (Don't forget to make a bitmap for
it!)
Remember, it's just for fun. Use it when scanning something or waiting
for something...
Author: Martijn Tonies
Date : 10-28-1996
E-mail: M.Tonies@hsbos.nl
{---8<------------------------------------------------------------------------} unit UKITScan; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls; const MaxLeds = 100; type TScanColor = (scBlue,scGreen,scRed,scYellow); TScanMode = (smLeftToRight,smRightToLeft,smBoth); TKITScanner = class(TGraphicControl) private FBevelInner: TPanelBevel; FBevelOuter: TPanelBevel; FBevelWidth: Byte; FHowManyLeds: Byte; FOutColor: TColor; FOnColor: TColor; FScanColor: TScanColor; FScanSpeed: Integer; FScanning: Boolean; FScanMode: TScanMode; FLedsColors: array [1..MaxLeds] of TScanColor; LedPos: Byte; LedWay: Boolean; Border: Byte; LedH,LedW: Integer; LedX: array [1..MaxLeds] of Integer; ScanTimer: TTimer; procedure DoScan(Sender: TObject); procedure Draw; procedure DrawBevel(Rect: TRect); procedure DrawLeds; procedure SetBevelInner(Value: TPanelBevel); procedure SetBevelOuter(Value: TPanelBevel); procedure SetBevelWidth(Value: Byte); procedure SetHowManyLeds(Value: Byte); procedure SetScanColor(Value: TScanColor); procedure SetScanMode(Value: TScanMode); procedure SetScanning(Value: Boolean); procedure SetScanSpeed(Value: Integer); procedure UpdateBorder; procedure UpdatePos; { Private declarations } protected { Protected declarations } public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Paint; override; { Public declarations } published property Align; property BevelInner: TPanelBevel read FBevelInner write SetBevelInner default bvNone; property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter default bvRaised; property BevelWidth: Byte read FBevelWidth write SetBevelWidth default 1; property Color; property Cursor; property Enabled; property HowManyLeds: Byte read FHowManyLeds write SetHowManyLeds default 7; property ScanColor: TScanColor read FScanColor write SetScanColor default scRed; property ScanMode: TScanMode read FScanMode write SetScanMode default smBoth; property Scanning: Boolean read FScanning write SetScanning default False; property ScanSpeed: Integer read FScanSpeed write SetScanSpeed default 100; property ShowHint; property Visible; { Published declarations } end; procedure Register; implementation {==============================================================================} {Private functions and procedures} procedure TKITScanner.Draw; var R: TRect; begin R:=GetClientRect; UpdateBorder; Drawbevel(R); InflateRect(R,-Border,-Border); Canvas.Brush.Style:=bsSolid; Canvas.Brush.Color:=Color; Canvas.FillRect(R); DrawLeds; end; {------------------} procedure TKITScanner.DrawBevel(Rect: TRect); var TopColor: TColor; BottomColor: TColor; procedure SetColors(Bevel: TPanelBevel); begin if Bevel=bvLowered then TopColor:=clBtnShadow else TopColor:=clBtnHighlight; if Bevel=bvLowered then BottomColor:=clBtnHighlight else BottomColor:=clBtnShadow; end; begin if FBevelOuterbvNone
then begin
SetColors(FBevelOuter);
Frame3D(Canvas,Rect,TopColor,BottomColor,FBevelWidth);
end;
if FBevelInnerbvNone
then begin
SetColors(FBevelInner);
Frame3D(Canvas,Rect,TopColor,BottomColor,FBevelWidth);
end;
end;
{------------------}
procedure TKITScanner.SetBevelInner(Value: TPanelBevel);
begin
if ValueFBevelInner
then begin
FBevelInner:=Value;
Draw;
end;
end;
procedure TKITScanner.SetBevelOuter(Value: TPanelBevel);
begin
if ValueFBevelOuter
then begin
FBevelOuter:=Value;
Draw;
end;
end;
procedure TKITScanner.SetBevelWidth(Value: Byte);
begin
if ValueFBevelWidth
then begin
FBevelWidth:=Value;
Draw;
end;
end;
procedure TKITScanner.UpdateBorder;
begin
Border:=0;
if FBevelInnerbvNone
then Border:=FBevelWidth;
if FBevelOuterbvNone
then Inc(Border,FBevelWidth);
end;
{------------------}
procedure TKITScanner.SetHowManyLeds(Value: Byte);
begin
if Value=0
then Value:=1;
if Value>MaxLeds
then Value:=MaxLeds;
if FHowManyLedsValue
then begin
FHowManyLeds:=Value;
Draw;
end;
end;
{------------------}
procedure TKITScanner.SetScanMode(Value: TScanMode);
begin
if ValueFScanMode
then FScanMode:=Value;
end;
{------------------}
procedure TKITScanner.SetScanSpeed(Value: Integer);
begin
if ValueFScanSpeed
then FScanSpeed:=Value;
if FScanning and Assigned(ScanTimer)
then ScanTimer.Interval:=FScanSpeed;
end;
{------------------}
procedure TKITScanner.SetScanColor(Value: TScanColor);
begin
if ValueFScanColor
then begin
FScanColor:=Value;
Draw;
end;
end;
{------------------}
procedure TKITScanner.SetScanning(Value: Boolean);
begin
if ValueFScanning
then begin
FScanning:=Value;
if FScanning
then begin
ScanTimer:=TTimer.Create(Self);
ScanTimer.Interval:=FScanSpeed;
ScanTimer.OnTimer:=DoScan;
ScanTimer.Enabled:=True;
end
else if Assigned(ScanTimer)
then begin
ScanTimer.Free;
ScanTimer:=nil;
end;
end;
end;
{------------------}
procedure TKITScanner.DrawLeds;
var n:Integer;
begin
LedH:=Height-Border-Border-2;
if LedH<1 then begin Height:=3+Border+Border; Draw; end; LedW:=(Width-Border-Border-1-FHowManyLeds) div FHowManyLeds; if LedW<1 then begin Width:=Border+Border+1+FHowManyleds*(2); Draw; end; if (Width(Border+Border+1+FHowManyLeds*(1+LedW))) and
((Align=alLeft) or (Align=alRight) or (Align=alNone))
then begin
Width:=Border+Border+1+FHowManyLeds*(1+LedW);
Draw;
end;
case FScanColor of
scBlue : begin
FOutColor:=clNavy;
FOnColor:=clBlue;
end;
scGreen : begin
FOnColor:=clLime;
FOutColor:=clGreen;
end;
scRed : begin
FOutColor:=clMaroon;
FOnColor:=clRed;
end;
scYellow : begin
FOutColor:=clOlive;
FOnColor:=clYellow;
end;
end;
Canvas.Brush.Color:=FOutColor;
Ledx[1]:=Border+1;
n:=2;
while n<=fhowmanyleds do begin Ledx[n]:=Ledx[n-1]+1+LedW; Inc(n); end; for n:=1 to FHowManyLeds do Canvas.FillRect(Rect(Ledx[n],Border+1,Ledx[n]+LedW,Height-Border-1)); end; {------------------} procedure TKITScanner.UpdatePos; begin case FScanMode of smBoth : if LedWay then if LedPos>FHowManyLeds
then LedWay:=not LedWay
else Inc(LedPos,1)
else if LedPos<1 then LedWay:=not LedWay else Dec(LedPos,1); smLeftToRight : begin LedWay:=True; if LedPos>FHowManyLeds
then LedPos:=0
else Inc(LedPos,1);
end;
smRightToLeft : begin
LedWay:=False;
if LedPos<1 then LedPos:=FHowManyLeds+1 else Dec(LedPos,1); end; end; end; procedure TKITScanner.DoScan; var n: Byte; begin Canvas.Brush.Color:=FOutColor; for n:=1 to FHowManyLeds do Canvas.FillRect(Rect(Ledx[n],Border+1,Ledx[n]+LedW,Height-Border-1)); UpdatePos; Canvas.Brush.Color:=FOnColor; if (LedPos>=1) and (LedPos<=fhowmanyleds)
then Canvas.FillRect(Rect(Ledx[LedPos],Border+1,Ledx[LedPos]+LedW,Height-Border-1));
end;
{==============================================================================}
{Protected functions and procedures}
{==============================================================================}
{Public functions and procedures}
constructor TKITScanner.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBevelInner:=bvNone;
FBevelOuter:=bvRaised;
FBevelWidth:=1;
FHowManyLeds:=7;
FScanColor:=scRed;
FScanSpeed:=100;
FScanMode:=smBoth;
LedPos:=1;
LedWay:=True;
Width:=82;
Height:=12;
end;
destructor TKITScanner.Destroy;
begin
if FScanning
then SetScanning(False);
inherited Destroy;
end;
procedure TKITScanner.Paint;
begin
Draw;
end;
{==============================================================================}
procedure Register;
begin
RegisterComponents('Samples', [TKITScanner]);
end;
end.