unit U_ScrollingLEDs3;
{Copyright  © 2001-2003, Gary Darby,  www.DelphiForFun.org
 This program may be used or modified for any non-commercial purpose
 so long as this original notice remains in place.
 All other rights are reserved
 }

{Scrolling LEDs program simulates those scrolling signs frequently used for
 advertising messages}

interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ComCtrls;

type
TLedchar=record
ch:array of array of byte; {character image}
charwidth:byte;  {width of character in LED units}
end;

  TForm1 = class(TForm)
    Image1: TImage;
    OpenDialog1: TOpenDialog;
    ColorDialog1: TColorDialog;
    LedGrp: TGroupBox;
    LEDPixelsUD: TUpDown;
    LEDSizeEdt: TEdit;
    Label3: TLabel;
    LEDColorBtn: TButton;
    LEDOffColorBtn: TButton;
    ShapeGrp: TRadioGroup;
    BoardColorBtn: TButton;
    ShowTextBtn: TButton;
    StopBtn: TButton;
    SpeedBar: TTrackBar;
    Label2: TLabel;
    MessagePages: TPageControl;
    Textpage: TTabSheet;
    DateTimePage: TTabSheet;
    Label1: TLabel;
    TextEdt: TEdit;
    DTFormatGrp: TRadioGroup;
    LoadFontBtn: TButton;
    FontLbl: TLabel;
    NewScreenBox: TCheckBox;
    Minimizebtnclick: TButton;
    StatusBar1: TStatusBar;
procedure ShowTextBtnClick(Sender: TObject);
procedure LoadFontBtnClick(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure BoardColorBtnClick(Sender: TObject);
procedure LEDColorBtnClick(Sender: TObject);
procedure LEDSizeEdtChange(Sender: TObject);
procedure LEDOffColorBtnClick(Sender: TObject);
procedure StopBtnClick(Sender: TObject);
procedure ShapeGrpClick(Sender: TObject);
procedure SpeedBarChange(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure MinimizebtnclickClick(Sender: TObject);
procedure NewScreenBoxClick(Sender: TObject);
procedure MessagePagesDrawTab(Control: TCustomTabControl;
      TabIndex: Integer; const Rect: TRect; Active: Boolean);
private
{ Private declarations }
public
{ Public declarations }
chars:array[0..255] of TLedchar;
    fontheight, maxcharwidth,nbrchars:integer;
    BoardColor,LEDOnColor,LEDOffColor:TColor; {Colors}
LEDSize:integer;  {LED pixel size}
RoundLED:boolean; {LED Shape}
DelayMS:integer; {Scrolling speed}
running:boolean;  {message is running}
function loadfont(fname:string):boolean;
procedure DrawBlankColumn(c:TCanvas; x1:integer);
function drawLED(c:TCanvas; startx:integer; chr:char):integer;
procedure animate(b:Tbitmap; s:string; image:TImage);
function getdatetimestring:string;
end;

var
Form1: TForm1;

implementation

uses U_LEDWindow;

{$R *.DFM}
{*************************** DrawBlankColumn *******************}
procedure TForm1.DrawBlankColumn(c:TCanvas; x1:integer);
{Draw a single column of LEDs in the off state at X1, return width in pixels}
var
x2,y1,y2,i:integer;
begin
with c do
begin
pen.width:=2;
       pen.color:=BoardColor;
       brush.color:=Boardcolor;
       y1:=0;
       y2:=LEDSize;
       x2:=x1+LEDSize;
for i:= 0 to fontheight-1 do
begin
rectangle(x1,y1,x2,y2);
         brush.color:=LEDOffColor;
If roundLED then ellipse(x1+1,y1+1,x2-1,y2-1)
else rectangle(x1,y1,x2,y2);
         inc(y1,ledsize);
         inc(y2,ledsize);
end;
end;
end;

{*************** DrawLED ******************}
function TForm1.drawLED(c:TCanvas; startx:integer; chr:char):integer;
{Draw LED character chr at startx - return the width in pixels}
var
i,j:integer;
  x1,x2,y1,y2:TColor;
begin
with c  do
begin
pen.width:=2;
    pen.color:=BoardColor;
for i:= 0 to fontheight-1 do
if chars[ord(chr)].charwidth>0 then
begin
y1:=i*LEDSize;
        y2:=y1+LEDSize;

for j:= 0 to high(chars[ord(chr)].ch[i]) do
begin
brush.color:=Boardcolor;
          x1:=startx+j*ledsize;
          x2:=x1+LEDSize;
if x1>=0 then
Begin
if RoundLEd then rectangle(x1,y1,x2,y2);
if chars[ord(chr)].ch[i,j]>0 then brush.color:=LEDOnColor
else brush.color:=LEDOffColor;
If RoundLED then ellipSe(x1+1,y1+1,x2-1,y2-1)
else rectangle(x1,y1,x2,y2);
end;
end;

{Now draw a blank column as spacer}
Inc(x1,LEDSize);
        drawblankcolumn(c,x1);
end;
end;
   result := (chars[ord(chr)].charwidth+1)*LEDSize;
end;

{************* LoadFont ****************}
function TForm1.loadfont(fname:string):boolean;
{Load a new font}
var
f:textfile;
  i,j,k:integer;
  charwidth,chrnbr:integer;
  line:string;
  errcode:integer;
  ext:string;

{Loadfont Local routines}
function getline:string;  {retrieve a line - skip comment lines}
var
comment:boolean;
begin
comment:=true;
          result:='';
repeat
readln(f,result);
if (length(result)>=2) and (copy(result,1,2)='!!') then
else  comment:=false;
until eof(f) or (comment=false);
end;

procedure errmsg(msg:string); {Show error msg}
begin
showmessage(msg);
          result:=false;
end;

begin  {LoadFont}
result:=true;
  ext:=extractfileext(fname);
  assignfile(f,fname);
  reset(f);
begin
line:=trim(getline);
    val(line,fontheight,errcode);
if errcode<>0 then errmsg('Invalid font FontHeight');
    inc(fontheight); {add room for a top row for internal leading}
line:=trim(getline);
    val(line,maxcharwidth,errcode);
if errcode<>0 then errmsg('Invalid font MaxCharWidth');
    line:=trim(getline);
    val(line,nbrchars,errcode);
if errcode<>0 then errmsg('Invalid font NbrChars');
for i:=1 to Nbrchars do
begin
if result=false then break;
      line:=trim(getline);
{' ' is used to define the space character}
if (length(line)=3) and (line=''' ''')  then line:=' ';
      chrnbr:=ord(line[1]);
begin
setlength(chars[chrnbr].ch,fontheight);
        line:=trim(getline);
        val(line,charwidth,errcode);
        chars[chrnbr].charwidth:=charwidth;
if errcode<>0
then errmsg('Invalid font CharWidth');
         setlength(chars[chrnbr].ch[0],charwidth);
for j:= 1 to fontheight-1 do   {start at 1 to leave 0th row blank}
begin
line:=getline;
if length(line)<charwidth then line:=line+stringofchar(' ',charwidth);
          setlength(chars[chrnbr].ch[j],charwidth);
for k:= 1 to charwidth do
if line[k]='#' then chars[chrnbr].ch[j,k-1]:=1
else chars[chrnbr].ch[j,k-1]:=0;
end;
end;
end;
end;
  closefile(f);
if chars[ord(' ')].charwidth=0 then {no space char defined, the normal case}
begin {make one}
charwidth:=maxcharwidth div 2 - 1;
    chars[ord(' ')].charwidth:=charwidth;
    setlength(chars[ord(' ')].ch,fontheight);
for j:=0 to fontheight-1 do setlength(chars[ord(' ')].ch[j],charwidth);
end;
If result then Fontlbl.caption:='Current Font: '+extractfilename(fname)
else FontLbl.caption:='No valid font loaded';
end; {Loadfont}

{************** FormActivate ***************}
procedure TForm1.FormActivate(Sender: TObject);
var s:string;
begin
with opendialog1 do
begin
initialdir:=extractfilepath(application.exename);
if fileexists(initialdir+'\arial.LED') then loadfont(initialdir+'\arial.LED')
else
if execute  then loadfont(filename)
else
begin
showmessage('No LED font found, program stopped');
      close;
end;
end;

  LEDSize:=LEDPixelsUD.position;
  LEDOnColor:=clRed;
  LEDOffColor:=$400040; {dark maroon}
BoardColor:=clBlack;
If shapeGRP.itemindex=0 then RoundLED:=true
else RoundLED:=False;
  DelayMS:=1000 div Speedbar.position;
  Stopbtn.left:=ShowtextBtn.left;
  Stopbtn.top:=ShowtextBtn.top;
  doublebuffered:=true;
With DTFormatGrp do
begin
datetimetostring(s,'mmm dd hh:nn ampm',now); items[0]:=s;
    datetimetostring(s,'hh:nn ampm',now); items[1]:=s;
    datetimetostring(s,'dddd, mmm dd, yyyy  hh:nn ampm',now); items[2]:=s;
end;
end;

function tform1.getdatetimestring:string;
begin
result:='????????';
case dtformatgrp.itemindex of
0: datetimetostring(result,'mmm dd hh:nn ampm      ',now);
    1: datetimetostring(result,'hh:nn ampm      ',now);
    2: datetimetostring(result,'dddd, mmm dd, yyyy  hh:nn ampm      ',now);
end;
end;

{************** Animate ****************}
procedure TForm1.animate(b:Tbitmap; s:string;  image:TImage);
{run the message image until tag <>0}
var
i:integer;
  startx:integer;
  charwidth:integer;
  prevtime:TDatetime;
  sx:integer;

function minutechanged:boolean;
var newtime:integer;
begin
newtime:=trunc(time*secsperday/60);
if newtime <>prevtime then
begin
result:=true;
        prevtime:=newtime;
end
else result:=false;
end;

begin
startx:=0;
WITH IMAGE DO
setbounds(left,top,width,b.height);

  image.canvas.rectangle(0,0,image.width,image.height);
  image.picture.assign(b);

{draw initial image}
for i:= 1 to length(s) do
begin
charwidth:=drawled(b.canvas, startx, s[i]);
    startx:=startx+charwidth;
end;
  image.Canvas.copyrect(rect(0,0,b.width,b.height),b.canvas,rect(0,0,b.width,b.height));
  application.processmessages;
{one time  - to save image for website  b.savetofile('HiYall.bmp');}
{Now scroll it}
startx:=0;
  prevtime:=0;
repeat
if (messagepages.activepage=Datetimepage) and minutechanged then
begin
{get new date time string}
s:=getdatetimestring;
      sx:=0;
for i:= 1 to length(s) do
begin
charwidth:=drawled(b.canvas, sx, s[i]);
        sx:=sx+charwidth;
end;
      image.Canvas.copyrect(rect(0,0,b.width,b.height),b.canvas,rect(0,0,b.width,b.height));
      image.update;
end;
    inc(startx,ledsize);
if startx > b.width then startx:=0;
    Image.canvas.copyrect(rect(0,0,b.width-startx,b.height),b.canvas,
                           rect(startx,0,b.width,b.height));
    Image.canvas.copyrect(rect(b.width-startx,0,b.width,b.height),b.canvas,
                            rect(0,0,startx,b.height));

    application.processmessages;
    sleep(Delayms);
until form1.tag<>0;
end;

{******************* ShowtextBtnClick ************}
procedure TForm1.ShowTextBtnClick(Sender: TObject);
var
s:string;
  i, j :integer;
  b:TBitmap;
  prevtime:integer;


function messagewidth(s:string):integer;
var
i:integer;
begin
result:=0;
for i:= 1 to length(s) do
result:=result+chars[ord(s[i])].charwidth+1;
    result:=result*LEDsize;
end;


begin
tag:=0;

  messagepages.enabled:=false;
  messagepages.Font.color:=clgray;
  LEDGrp.enabled:=false;
  ledgrp.font.color:=clgray;
  ledcolorbtn.enabled:=false;
  ledoffcolorbtn.enabled:=false;
  boardcolorbtn.enabled:=false;
  stopbtn.visible:=true;

  running:=true;
if messagepages.activepage=textpage then s:=textedt.text
else s:=getdatetimestring;
  b:=TBitmap.create;
  b.height:=fontheight*LEDsize;
  b.width:=messagewidth(s);
if newscreenbox.checked then {show message on a separate form}
begin
ledform.clientheight:=b.height;
    windowstate:=wsminimized;
    ledform.show;
    animate(b,s,ledform.image1);
    ledform.hide;
end
else animate(b,s,image1);
  stopbtn.visible:=false;
  messagepages.enabled:=true;
  messagepages.font.color:=clblack;
  LEDGrp.enabled:=true;
  ledgrp.font.color:=clblack;
  ledcolorbtn.enabled:=true;
  ledoffcolorbtn.enabled:=true;
  boardcolorbtn.enabled:=true;
  b.free;
  running:=false;
end;

{**************** LoadFontBtnClick *************}
procedure TForm1.LoadFontBtnClick(Sender: TObject);
var  savestate:boolean;
begin
savestate:=running;
if running then tag:=1;
If opendialog1.execute then loadfont(opendialog1.filename);
if savestate then ShowTextBtnClick(sender);
end;

{**************** BoardColorBtnClick ****************}
procedure TForm1.BoardColorBtnClick(Sender: TObject);
begin If colordialog1.execute then boardcolor:=colordialog1.color; end;

{************** LEDColorBtnClick ****************}
procedure TForm1.LEDColorBtnClick(Sender: TObject);
begin  If colordialog1.execute then LEDOncolor:=colordialog1.color; end;

{************* LEDSizeEdtChange ***************}
procedure TForm1.LEDSizeEdtChange(Sender: TObject);
begin   LEDSize:=LEDPixelsUD.position;  end;

{**************** LEDOffColorBrnClick *************}
procedure TForm1.LEDOffColorBtnClick(Sender: TObject);
begin  If colordialog1.execute then LEDOffcolor:=colordialog1.color; end;

{**************** StopBtnClick ***************}
procedure TForm1.StopBtnClick(Sender: TObject);
begin    tag:=1;  end;

{************** ShapeGrpClick ************}
procedure TForm1.ShapeGrpClick(Sender: TObject);
begin
If shapeGRP.itemindex=0 then RoundLED:=true  else RoundLED:=False;
end;
{******************* SpeedBarChange *************}
procedure TForm1.SpeedBarChange(Sender: TObject);
begin
DelayMs:=1000 div speedbar.position;
if speedbar.position=speedbar.max then DelayMs:=5;
end;
{*************** FormClosrQuery ****************}
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
tag:=1; {to stop message in case it's scrolling}
canclose:=true;
end;

{****************** Minimizebtnclick **********}
procedure TForm1.MinimizebtnclickClick(Sender: TObject);
{minimize this form}
begin  windowstate:=wsMinimized;  end;

{***************** NewScreenBoxCkick **********}
procedure TForm1.NewScreenBoxClick(Sender: TObject);
var savestate:boolean;
begin
savestate:=running;
if running then tag:=1;
  application.processmessages;
if savestate then ShowTextBtnClick(sender);
end;

{************** MessagepagesDrawTab *******************}
procedure TForm1.MessagePagesDrawTab(Control: TCustomTabControl;
{Draw tabs in gray if control is disabled - no other way to do it?}
TabIndex: Integer; const Rect: TRect; Active: Boolean);
begin
with TPageControl(control), canvas do
begin
if enabled then pen.color:=clred else pen.color:=clgray;
If tabindex=0 then textout(rect.left+4, rect.top+4, 'Message')
else textout(rect.left+4, rect.top+4, 'Date/Time');
end;
end;

end.