Contributor: UDO JUERSS
{
This component uses the VGA standard 8x16 font. No resources are used.
properties description:
property BackGround: Background color of panel. Not visible if size is 1,
because pixeldensity is too high.
property BevelOuter: as usual.
property BevelInner: as usual.
property BevelWidth: as usual.
property Characters: How many Character are displayed in panel.
Increasing this slows down the outputspeed.
property OffColor: Color of Pixels not set in character.
property OnColor: Color of Pixels set in character.
property OnComplete: Fired if output of RunText completed.
property Running: Flag if horizontal scrolling is active.
property RunText: Outputstring.
property ScrollBy: Number of pixels per horizontal scroll.
property ScrollInterval: Cycletime of horizontal scrolling.
property Size: Size of output. If set to 1 character size is 8x16
pixels. Increasing size decreases display contrast.
Contact: Udo Juerss, 57078 Siegen, Germany, CompuServe [101364,526]
Previously published by me: Luffing switch (March 8. 1996)
Scaleable LED light (March 10. 1996)
If someone makes useful enhances or corrections to these components,
please send me an update!
March 11. 1996
}
unit
Marquee;
{------------------------------------------------------------------------------}
interface
uses
WinTypes, WinProcs, Messages, Classes, Graphics, Controls, ExtCtrls;
{------------------------------------------------------------------------------}
const
Dual: array[0..7] of Byte = (1,2,4,8,16,32,64,128);
{------------------------------------------------------------------------------}
type
TMarquee = class(TGraphicControl)
private
Timer: TTimer;
FBackGround: TColor;
FBevelOuter: TPanelBevel;
FBevelInner: TPanelBevel;
FBevelWidth: Byte;
FBkGnd: TColor;
FCharacters: Byte;
FScrollInterval: Word;
FOffColor: TColor;
FOnColor: TColor;
FOnComplete: TNotifyEvent;
FRunning: Boolean;
FRunText: string;
FSize: Byte;
FScrollBy: Byte;
Border:Byte;
Index: Byte;
WorkString: string;
PixelPos: Byte;
CharOfs: Word;
TextLen: Byte;
XPos: Integer;
YPos: Integer;
procedure Draw;
procedure DrawText(Shift:Boolean);
procedure GetCharData(Character: Char);
procedure PutVerticalPixels(Horizontal: Byte);
procedure Setup;
procedure ShiftString;
procedure TimerShift(Sender: TObject);
protected
procedure DrawBevel(Rect: TRect);
procedure SetBackGround(Value: TColor);
procedure SetBevelOuter(Value: TPanelBevel);
procedure SetBevelInner(Value: TPanelBevel);
procedure SetBevelWidth(Value: Byte);
procedure SetCharacters(Value: Byte);
procedure SetScrollInterval(Value: Word);
procedure SetOffColor(Value: TColor);
procedure SetOnColor(Value: TColor);
procedure SetRunning(Value: Boolean);
procedure SetRunText(Value: string);
procedure SetSize(Value: Byte);
procedure SetScrollBy(Value: Byte);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Clear;
procedure Paint; override;
published
property BackGround: TColor read FBackGround write SetBackGround default clBlack;
property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter default bvRaised;
property BevelInner: TPanelBevel read FBevelInner write SetBevelInner default bvLowered;
property BevelWidth: Byte read FBevelWidth write SetBevelWidth default 2;
property Characters: Byte read FCharacters write SetCharacters default 7;
property ScrollInterval: Word read FScrollInterval write SetScrollInterval default 50;
property OffColor: TColor read FOffColor write SetOffColor default clGray;
property OnColor: TColor read FOnColor write SetOnColor default clLime;
property OnComplete: TNotifyEvent read FOnComplete write FOnComplete;
property Running: Boolean read FRunning write SetRunning default False;
property RunText: string read FRunText write SetRunText;
property ScrollBy: Byte read FScrollBy write SetScrollBy default 1;
property Size: Byte read FSize write SetSize default 2;
end;
{------------------------------------------------------------------------------}
procedure GetFontOfs(CharSet: Byte; var FntOfs: Word);
function SegC000: Word;
procedure Register;
implementation
{------------------------------------------------------------------------------}
var
CharArray: array[0..15] of Byte;
FontPtr: Pointer;
FontOfs: Word;
{------------------------------------------------------------------------------}
procedure GetFontOfs(CharSet: Byte; var FntOfs: Word); assembler;
asm
push bp
mov ax,1130h
mov bh,CharSet
int 10h
mov ax,bp
pop bp
les di,FntOfs
stosw
end;
{------------------------------------------------------------------------------}
function SegC000: Word; external 'KERNEL' Index 195;
{------------------------------------------------------------------------------}
constructor TMarquee.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Parent:=AOwner as TWinControl;
Canvas.Brush.Style:=bsSolid;
Timer:=nil;
FBackGround:=clBlack;
FBevelOuter:=bvRaised;
FBevelInner:=bvLowered;
FBevelWidth:=2;
FCharacters:=7;
FScrollInterval:=50;
FOffColor:=clGray;
FOnColor:=clLime;
FOnComplete:=nil;
FRunning:=False;
FRunText:='RunText ';
FSize:=2;
FScrollBy:=1;
Border:=2;
GetFontOfs(6,FontOfs);
FontPtr:=Ptr(Ofs(SegC000),FontOfs);
PixelPos:=0;
TextLen:=Length(FRunText);
Index:=0;
WorkString:=FRunText;
Setup;
Draw;
end;
{------------------------------------------------------------------------------}
destructor TMarquee.Destroy;
begin
if FRunning then SetRunning(False);
inherited Destroy;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.Paint;
begin
Draw;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.Clear;
var
Temp: Byte;
begin
Temp:=FOnColor;
FOnColor:=FOffColor;
DrawText(False);
FOnColor:=Temp;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.Draw;
var
R: TRect;
begin
R:=GetClientRect;
DrawBevel(R);
Canvas.Pen.Color:=FBackGround;
Canvas.Brush.Color:=FBackGround;
InflateRect(R,-Border,-Border);
Canvas.FillRect(R);
DrawText(False);
end;
{------------------------------------------------------------------------------}
procedure TMarquee.DrawBevel(Rect: TRect);
var
TopColor: TColor;
BottomColor: TColor;
procedure SetColors(Bevel: TPanelBevel);
begin
TopColor:=clBtnHighlight;
if Bevel = bvLowered then TopColor:=clBtnShadow;
BottomColor:=clBtnShadow;
if Bevel = bvLowered then BottomColor:=clBtnHighlight;
end;
begin
if FBevelOuter bvNone then
begin
SetColors(BevelOuter);
Frame3D(Canvas,Rect,TopColor,BottomColor,BevelWidth);
end;
if FBevelInner bvNone then
begin
SetColors(FBevelInner);
Frame3D(Canvas,Rect,TopColor,BottomColor,FBevelWidth);
end;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.DrawText(Shift: Boolean);
var
Pos: Byte;
I: Byte;
R: TRect;
begin
R:=GetClientRect;
XPos:=R.Left + Border;
YPos:=R.Top + Border;
GetCharData(WorkString[1]);
for I:=PixelPos to 7 do PutVerticalPixels(I);
for Pos:=2 to FCharacters do
begin
GetCharData(WorkString[Pos]);
for I:=0 to 7 do PutVerticalPixels(I);
end;
GetCharData(WorkString[Succ(FCharacters)]);
for I:=0 to PixelPos do PutVerticalPixels(I);
if Shift then Inc(PixelPos,FScrollBy);
if PixelPos> 7 then
begin
PixelPos:=0;
ShiftString;
end;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.GetCharData(Character: Char); assembler;
asm
push ds
push ds
pop es
mov di,offset CharArray
xor bh,bh
mov bl,Character
shl bx,4
lds si,FontPtr
add si,bx
mov cx,16
@MovsLoop: push cx
lodsb
mov ah,0
mov cx,8
@RolLoop: rol al,1
adc ah,0
ror ah,1
loop @RolLoop
mov al,ah
stosb
pop cx
loop @MovsLoop
pop ds
end;
{------------------------------------------------------------------------------}
procedure TMarquee.PutVerticalPixels(Horizontal: Byte);
var
Vertical: Byte;
begin
for Vertical:=0 to 15 do
begin
if CharArray[Vertical] and Dual[Horizontal]> 0 then
Canvas.Pixels[XPos,YPos + Vertical * FSize]:=FOnColor
else Canvas.Pixels[XPos,YPos + Vertical * FSize]:=FOffColor;
end;
Inc(XPos,FSize);
end;
{------------------------------------------------------------------------------}
procedure TMarquee.TimerShift(Sender: TObject);
begin
DrawText(True);
end;
{------------------------------------------------------------------------------}
procedure TMarquee.ShiftString;
begin
Inc(Index);
if FCharacters>= TextLen - Index then
begin
WorkString:=Copy(FRunText,Succ(Index),TextLen - Index);
WorkString:=WorkString + Copy(RunText,1,Succ(FCharacters) - (TextLen - Index));
end
else WorkString:=Copy(FRunText,Succ(Index),Succ(FCharacters));
if Index>= TextLen then
begin
Index:=0;
if Assigned(FOnComplete) then FOnComplete(Self);
end;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.Setup;
begin
Width:=FSize * 8 * FCharacters + 2 * Border + 1;
Height:=FSize * 16 + 2 * Border;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.SetBackGround(Value: TColor);
begin
if FBackGround Value then
begin
FBackGround:=Value;
Draw;
end;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.SetBevelOuter(Value: TPanelBevel);
begin
if FBevelOuter Value then
begin
FBevelOuter:=Value;
if FBevelOuter bvNone then Border:=FBevelWidth else Border:=0;
if FBevelInner bvNone then Inc(Border,FBevelWidth);
Setup;
Draw;
end;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.SetBevelInner(Value: TPanelBevel);
begin
if FBevelInner Value then
begin
FBevelInner:=Value;
if FBevelOuter bvNone then Border:=FBevelWidth else Border:=0;
if FBevelInner bvNone then Inc(Border,FBevelWidth);
Setup;
Draw;
end;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.SetBevelWidth(Value: Byte);
begin
if FBevelWidth Value then
begin
FBevelWidth:=Value;
if FBevelOuter bvNone then Border:=FBevelWidth else Border:=0;
if FBevelInner bvNone then Inc(Border,FBevelWidth);
Setup;
Draw;
end;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.SetCharacters(Value: Byte);
var
I: Byte;
begin
if Value < 1 then Value:=1 else if Value> 80 then Value:=80;
if FCharacters Value then
begin
FCharacters:=Value;
if TextLen < FCharacters then begin for I:=TextLen to FCharacters do FRunText:=FRunText + ' '; TextLen:=Byte(FRunText[0]); end; SetUp; Draw; end; end; {------------------------------------------------------------------------------} procedure TMarquee.SetScrollInterval(Value: Word); begin if FScrollInterval Value then
begin
FScrollInterval:=Value;
if FRunning and Assigned(Timer) then Timer.Interval:=FScrollInterval;
end;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.SetSize(Value: Byte);
begin
if Value < 1 then Value:=1 else if Value> 8 then Value:=8;
if FSize Value then
begin
FSize:=Value;
SetUp;
Draw;
end;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.SetScrollBy(Value: Byte);
begin
if Value < 1 then Value:=1 else if Value> 8 then Value:=8;
if FScrollBy Value then FScrollBy:=Value;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.SetOffColor(Value: TColor);
begin
if FOffColor Value then
begin
FOffColor:=Value;
Draw;
end;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.SetOnColor(Value: TColor);
begin
if FOnColor Value then
begin
FOnColor:=Value;
Draw;
end;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.SetRunning(Value: Boolean);
begin
if FRunning Value then
begin
FRunning:=Value;
if FRunning then
begin
Timer:=TTimer.Create(Self);
Timer.Interval:=FScrollInterval;
Timer.OnTimer:=TimerShift;
Timer.Enabled:=True;
end
else if Assigned(Timer) then
begin
Timer.Free;
Timer:=nil;
end;
end;
end;
{------------------------------------------------------------------------------}
procedure TMarquee.SetRunText(Value: string);
var
I: Byte;
begin
Index:=0;
FRunText:=Value;
TextLen:=Byte(FRunText[0]);
if TextLen < FCharacters then for I:=TextLen to FCharacters do FRunText:=FRunText + ' ';
TextLen:=Byte(FRunText[0]);
end;
{------------------------------------------------------------------------------}
procedure Register;
begin
RegisterComponents('Udo|s',[TMarquee]);
end;
{------------------------------------------------------------------------------}
initialization
end.