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 FBevelOuter<>bvNone
then begin
SetColors(FBevelOuter);
Frame3D(Canvas,Rect,TopColor,BottomColor,FBevelWidth);
end;
if FBevelInner<>bvNone
then begin
SetColors(FBevelInner);
Frame3D(Canvas,Rect,TopColor,BottomColor,FBevelWidth);
end;
end;
{------------------}
procedure TKITScanner.SetBevelInner(Value: TPanelBevel);
begin
if Value<>FBevelInner
then begin
FBevelInner:=Value;
Draw;
end;
end;
procedure TKITScanner.SetBevelOuter(Value: TPanelBevel);
begin
if Value<>FBevelOuter
then begin
FBevelOuter:=Value;
Draw;
end;
end;
procedure TKITScanner.SetBevelWidth(Value: Byte);
begin
if Value<>FBevelWidth
then begin
FBevelWidth:=Value;
Draw;
end;
end;
procedure TKITScanner.UpdateBorder;
begin
Border:=0;
if FBevelInner<>bvNone
then Border:=FBevelWidth;
if FBevelOuter<>bvNone
then Inc(Border,FBevelWidth);
end;
{------------------}
procedure TKITScanner.SetHowManyLeds(Value: Byte);
begin
if Value=0
then Value:=1;
if Value>MaxLeds
then Value:=MaxLeds;
if FHowManyLeds<>Value
then begin
FHowManyLeds:=Value;
Draw;
end;
end;
{------------------}
procedure TKITScanner.SetScanMode(Value: TScanMode);
begin
if Value<>FScanMode
then FScanMode:=Value;
end;
{------------------}
procedure TKITScanner.SetScanSpeed(Value: Integer);
begin
if Value<>FScanSpeed
then FScanSpeed:=Value;
if FScanning and Assigned(ScanTimer)
then ScanTimer.Interval:=FScanSpeed;
end;
{------------------}
procedure TKITScanner.SetScanColor(Value: TScanColor);
begin
if Value<>FScanColor
then begin
FScanColor:=Value;
Draw;
end;
end;
{------------------}
procedure TKITScanner.SetScanning(Value: Boolean);
begin
if Value<>FScanning
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.