unit Unit1;
{$mode objfpc}{$H+}
{.Define PoorFontButUndo}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
StdCtrls;
const
gcBigUndo=10;
type
{ TForm1 }
TForm1 = class(TForm)
BackgroundImage1: TImage;
UndoButton1: TButton;
ModifyButton1: TButton;
Panel1: TPanel;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure ModifyButton1Click(Sender: TObject);
procedure UndoButton1Click(Sender: TObject);
private
{ private declarations }
fInitBkgImg,
fTempImg0 :TImage;
fUndoImgs :array[0..gcBigUndo] of TImage;
function RestoreUndoImg:TImage;
procedure SaveUndoImg(pImg:TImage);
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
const
gcBigX=4;
gcBigY=11;
var
gPicked :array[0..gcBigX,0..gcBigY] of boolean;
function TForm1.RestoreUndoImg:TImage;
var I:integer;
begin
fTempImg0.Picture:=fUndoImgs[0].Picture;
for I:=1 to gcBigUndo do
fUndoImgs[I-1].Picture:=fUndoImgs[I].Picture;
fUndoImgs[gcBigUndo].Picture:=fInitBkgImg.Picture;
RestoreUndoImg:=fTempImg0;
end;
procedure TForm1.SaveUndoImg(pImg:TImage);
var I:integer;
begin
for I:=gcBigUndo-1 downto 0 do
fUndoImgs[I+1].Picture:=fUndoImgs[I].Picture;
fUndoImgs[0].Picture:=pImg.Picture;
end;
procedure TForm1.ModifyButton1Click(Sender: TObject);
const
cWidth=200; cHeight=50;
cColours:array[0..21] of TColor=(clAqua,clBlack,clBlue,clCream,clDkGray,
clFuchsia,clGray,clGreen,clLime,clLtGray,clMaroon,clMedGray,clMoneyGreen,
clNavy,clOlive,clPurple,clRed,clSilver,clSkyBlue,clTeal,clWhite,clYellow);
var X0,X1,X2,Y0,Y1,Y2,vCnt:integer; S:string; vColour:TColor;
begin
vCnt:=0;
repeat
X0:=Random(gcBigX);
Y0:=Random(gcBigY);
inc(vCnt);
until (gPicked[X0,Y0]=false) or (vCnt>200);
gPicked[X0,Y0]:=true;
X1:=X0*cWidth;
Y1:=Y0*cHeight;
X2:=X1+cWidth-10;
Y2:=Y1+35;
SaveUndoImg(BackgroundImage1);
{$IfDef PoorFontButUndo}
with BackgroundImage1.Picture.Bitmap do begin
Canvas.Font.Name:='Arial';
Canvas.Font.Size:=20;
vColour:=cColours[Random(22)];
Canvas.Font.Color:=vColour;
Canvas.Brush.Style:=bsclear;
S:=FormatDateTime('hh:mm:ss.zzz',now);
Canvas.TextOut(X1,Y1,S);
Canvas.Brush.Style:=bsSolid;
Canvas.Brush.Color:=vColour;
Canvas.FillRect(X1,Y2,X2,Y2+10);
end;
{$Else PoorFontButUndo}
with BackgroundImage1.Canvas do begin
Canvas.Font.Name:='Arial Black';
Canvas.Font.Size:=20;
vColour:=cColours[Random(22)];
Canvas.Font.Color:=vColour;
Canvas.Brush.Style:=bsclear;
S:=FormatDateTime('hh:mm:ss.zzz',now);
Canvas.TextOut(X1,Y1,S);
Canvas.Brush.Style:=bsSolid;
Canvas.Brush.Color:=vColour;
Canvas.FillRect(X1,Y2,X2,Y2+10);
end;
{$EndIf PoorFontButUndo}
end;
procedure TForm1.UndoButton1Click(Sender: TObject);
begin
BackgroundImage1.Picture.Assign(RestoreUndoImg.Picture);
end;
procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
var I:integer;
begin
try
for I:=gcBigUndo downto 0 do begin
// fUndoImgs[I].Picture.Assign(nil);
// fUndoImgs[I].Free;
fUndoImgs[I].FreeOnRelease;
end;
except
ShowMessageFmt('Image exception at %d.',[I]);
end;
fInitBkgImg.Free;
fTempImg0.Free;
end;
procedure TForm1.FormShow(Sender: TObject);
var I:integer;
begin
fInitBkgImg.Picture.Assign(BackgroundImage1.Picture);
for I:=0 to gcBigUndo do
fUndoImgs[I].Picture.Assign(fInitBkgImg.Picture);
end;
procedure TForm1.FormCreate(Sender: TObject);
var I,J:integer;
begin
Randomize;
for I:=0 to gcBigX do
for J:=0 to gcBigY do
gPicked[I,J]:=false;
fInitBkgImg:=TImage.Create(nil);
fTempImg0:=TImage.Create(nil);
for I:=0 to gcBigUndo do
fUndoImgs[I]:=TImage.Create(nil);
end;
end.