Performances with FastReport TFrxCrossObject and large Grids (> 1000 rows) - delphi

I use FastReport and I need to preview/print Grids with more than 1000 rows and I have some performances problems.
Typically I use TfrxCrossObject to prepare my grid because the end user may change the grid presentation (used columns, column's name, size) so I need to have a dynamical print.
I tested a simple grid (16 cols x2000 rows) and it needs more than 10 seconds to present the first preview page.
Any idea to improve performances ?
EDIT :
As said in some answers, the problem is : how to create 'dynamicaly' a grid (with same columns names and sizes that I have on screen) in FastReport without using TFrxCrossObject which seems to be not very efficent. I may admit all solutions like using DataSet or enhancing TfrxCrossObject.
The test code :
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
frxClass, StdCtrls, Grids, frxCross;
type
TForm1 = class(TForm)
Button1: TButton;
StringGrid1: TStringGrid;
frxCrossObject1: TfrxCrossObject;
frxReport1: TfrxReport;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure frxReport1BeforePrint(c: TfrxReportComponent);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
i, j: Integer;
begin
for i := 1 to 16 do
for j := 1 to 2000 do
StringGrid1.Cells[i - 1, j - 1] := IntToStr(i * j);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
frxReport1.ShowReport;
end;
procedure TForm1.frxReport1BeforePrint(c: TfrxReportComponent);
var
Cross: TfrxCrossView;
i, j: Integer;
begin
if c is TfrxCrossView then
begin
Cross := TfrxCrossView(c);
for i := 1 to 16 do
for j := 1 to 2000 do
Cross.AddValue([i], [j], [StringGrid1.Cells[i - 1, j - 1]]);
end;
end;
end.

The CrossTab have many overhead. Here is a UserDataSet version :
Just drop 1 stringgrid, 1 button, 1 frxReport, 1 frxUserDataSet in the form.
Set the frxUserDataSet events, Form OnCreate and Buttom OnClick as below code.
No need to Design Report or set any properties, All will be set or generated at run-time.
It seems it is faster than the cross-tab version but you need more coding and lost functionality of CrossObject.
Edit : Add some comments and fix PaperWidth mis-calculation.
Edit2 : Add a print-friendly version which split data into pages.
View Friendly version show in 1 single page as the stringgrid :
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, frxClass, Grids, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
StringGrid1: TStringGrid;
frxReport1: TfrxReport;
frxUserDataSet1: TfrxUserDataSet;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure frxUserDataSet1Next(Sender: TObject);
procedure frxUserDataSet1GetValue(const VarName: string; var Value: Variant);
procedure frxUserDataSet1CheckEOF(Sender: TObject; var Eof: Boolean);
procedure frxUserDataSet1First(Sender: TObject);
private
X, Y, TCol, TRow : Integer;
IsEof : Boolean;
CW, CH, PF : Double;
Page : TfrxReportPage;
MDB : TfrxMasterData;
Memo : TfrxMemoView;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
BW : Double;
begin
IsEof := False;
Page.PaperWidth := CW * TCol + 20; // EndlessWidth seems not work with band column
MDB.SetBounds(0,0, CW * PF * TCol, CH * PF);
MDB.Columns := TCol;
MDB.ColumnWidth := CW * PF;
frxReport1.ShowReport;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i, j : Integer;
begin
CW := 12; // Cell Width in mm
CH := 5; // Cell Height in mm
PF := 3.7794; // Pixie Factor i.e. the conversion of mm to FR component measurement
TCol := 2000; // Total Column
TRow := 16; // Total Row
for i := 1 to TRow do
for j := 1 to TCol do
StringGrid1.Cells[i - 1, j - 1] := IntToStr(i * j);
frxUserDataSet1.Fields.Text := 'Data';
frxReport1.Clear;
frxReport1.DataSets.Add(frxUserDataSet1);
Page := TfrxReportPage.Create(frxReport1);
Page.CreateUniqueName;
Page.TopMargin := 10;
Page.BottomMargin := 10;
Page.LeftMargin := 10;
Page.RightMargin := 10;
Page.EndlessHeight := True;
Page.EndlessWidth := True;
MDB := TfrxMasterData.Create(Page);
MDB.DataSet := frxUserDataSet1;
Memo := TfrxMemoView.Create(MDB);
Memo.SetBounds(0,0,CW * PF,CH * PF);
Memo.Memo.Text := '[frxUserDataSet1."Data"]';
Memo.Frame.Typ := [ftLeft, ftRight, ftTop, ftBottom];
end;
procedure TForm1.frxUserDataSet1CheckEOF(Sender: TObject; var Eof: Boolean);
begin
Eof := IsEof;
end;
procedure TForm1.frxUserDataSet1First(Sender: TObject);
begin
X := 0;
Y := 0;
end;
procedure TForm1.frxUserDataSet1GetValue(const VarName: string; var Value: Variant);
begin
Value := StringGrid1.Cells[X,Y];
end;
procedure TForm1.frxUserDataSet1Next(Sender: TObject);
begin
If Y = TCol - 1 then
begin
if X = TRow - 1 then
IsEof := True;
Inc(X);
Y := 0;
end
else
Inc(Y);
end;
end.
Print-friendly version which is a bit more complex and separate data in different pages for printing :
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, frxClass, Grids, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
StringGrid1: TStringGrid;
frxReport1: TfrxReport;
frxUserDataSet1: TfrxUserDataSet;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure frxUserDataSet1Next(Sender: TObject);
procedure frxUserDataSet1GetValue(const VarName: string; var Value: Variant);
procedure frxUserDataSet1CheckEOF(Sender: TObject; var Eof: Boolean);
procedure frxUserDataSet1First(Sender: TObject);
private
X, Y, TCol, TRow, RPP, ColBreak : Integer;
IsEof : Boolean;
CW, CH, PF : Double;
Page : TfrxReportPage;
MDB : TfrxMasterData;
Memo : TfrxMemoView;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Math;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
BW : Double;
begin
IsEof := False;
RPP := Ceil((Page.PaperHeight - Page.TopMargin - Page.BottomMargin) / CH) - 1; // Row per page
ColBreak := RPP; // break to next column
frxReport1.ShowReport;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i, j : Integer;
begin
CW := 12; // Cell Width in mm
CH := 5; // Cell Height in mm
PF := 3.7794; // Pixil Factor i.e. the conversion of mm to FR component measurement
TCol := 2000; // Total Column
TRow := 16; // Total Row
for i := 1 to TRow do
for j := 1 to TCol do
StringGrid1.Cells[i - 1, j - 1] := IntToStr(i * j);
frxUserDataSet1.Fields.Text := 'Data';
frxReport1.Clear;
frxReport1.DataSets.Add(frxUserDataSet1);
Page := TfrxReportPage.Create(frxReport1);
Page.CreateUniqueName;
Page.TopMargin := 10;
Page.BottomMargin := 10;
Page.LeftMargin := 10;
Page.RightMargin := 10;
Page.Columns := Ceil(Page.PaperWidth / CW);
MDB := TfrxMasterData.Create(Page);
MDB.DataSet := frxUserDataSet1;
MDB.SetBounds(0,0, CW * PF, CH * PF);
Memo := TfrxMemoView.Create(MDB);
Memo.Align := baClient;
Memo.Memo.Text := '[frxUserDataSet1."Data"]';
Memo.Frame.Typ := [ftLeft, ftRight, ftTop, ftBottom];
end;
procedure TForm1.frxUserDataSet1CheckEOF(Sender: TObject; var Eof: Boolean);
begin
Eof := IsEof;
end;
procedure TForm1.frxUserDataSet1First(Sender: TObject);
begin
X := 0;
Y := 0;
end;
procedure TForm1.frxUserDataSet1GetValue(const VarName: string; var Value: Variant);
begin
Value := StringGrid1.Cells[X,Y];
end;
procedure TForm1.frxUserDataSet1Next(Sender: TObject);
begin
If X = TRow - 1 then
begin
if Y = TCol - 1 then
IsEof := True
else
begin
frxReport1.Engine.NewColumn;
Inc(Y);
X := ColBreak - RPP;
end;
end
else if (X = ColBreak - 1) then
begin
if Y = TCol - 1 then
begin
frxReport1.Engine.NewPage;
ColBreak := ColBreak + RPP;
Y := 0;
end
else
Inc(Y);
frxReport1.Engine.NewColumn;
X := ColBreak - RPP;
end
else
Inc(X);
end;
end.

Your piece of code correspond to the PrintStringGrid demo of FastReport slightly modified (RowCount=2000 instead of 16).
Using TStringGrid as a container is not a good idea if you have to deal with large data: It should only be used for presention concern.
Use an in-memory dataset (e.g. ClientDataset as teran suggested in the question comment thread), you can still present your large data to a TStringGrid if using it is compulsory but a TDBGrid is more appropriate.
Iterating a large TDataset is fast than doing the same with a mere TStringGrid.
The PrintTable demo of FastReport could serve as a starting point, adapting it is left to you as an exercise knowing that it uses the same components as PrintStringGrid demo:
A TfrxReport and
A TfrxCrossObject where the iteration takes place.

Related

how to move two bitmap-image on a canvas

I am writing an animation program under Delphi 7 consisting of moving two discs on a canvas (I choose a PaintBox) with a bounce effect on the edges.
it's woks fine if I load the pictures one by one: In this case, when the two disks that arrive from time to time are superimposed, no background rectangle appears with even a rather pleasant transparency effect.
But if I try to generalize the operation with many more discs by introducing for example a Record.
The movements are ok BUT in this case, when the discs cross, a background
rectangle appears in the upper image which spoils everything!
I even tried to write the code with an Object with :
TSphere = class (TObject)
but nothing to do, the phenomenon remains ..
Do you have any idea how to remove this display defect?
and i have another question, i would like to fill the disks with textures.
the full code :
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, ComCtrls;
type
TSphere = record
W, H: integer;
vx, vy: Extended;
x, y: integer;
xx, yy: extended;
ROld, RNew: TRect;
Bitm: TBitmap;
end;
type
TForm1 = class(TForm)
PaintBox1: TPaintBox;
Button1: TButton;
Timer1: TTimer;
Label1: TLabel;
Edit1: TEdit;
Label2: TLabel;
TrackBar1: TTrackBar;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure TrackBar1Change(Sender: TObject);
end;
var
Form1: TForm1;
fin: boolean;
BmpBkg: Tbitmap;
BmpMoving: TBitmap;
Spheres: array of TSphere;
const
nb = 2;
ImageWidth = 32;
implementation
{$R *.DFM}
procedure PictureStorage;
var
i: integer;
begin
SetLength(Spheres, nb);
for i := 0 to (nb - 1) do
begin
with Spheres[i] do
begin
Bitm := TBitmap.Create;
case i of
0: Bitm.loadFromFile('Sphere1.bmp');
1: Bitm.loadFromFile('Sphere2.bmp');
end;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i: integer;
begin
DoubleBuffered := true;
randomize;
Fin := false;
BmpBkg := TBitmap.Create;
BmpMoving := TBitmap.Create;
BmpBkg .Canvas.Brush.Color := ClBtnFace;
BmpBkg .Canvas.FillRect(Rect(0, 0, PaintBox1.height,
PaintBox1.width));
BmpBkg .Width := PaintBox1.Width;
BmpBkg .Height := PaintBox1.Height;
BmpMoving .Assign(BmpBkg );
PictureStorage;
for i := 0 to (nb - 1) do
begin
with Spheres[i] do
begin
W := Bitm.Width;
H := Bitm.Height;
Bitm.Transparent := True;
Bitm.TransParentColor := Bitm.canvas.pixels[1, 1];
xx := random(400) + 1;
yy := random(200) + 1;
x := trunc(xx);
y := trunc(yy);
vx := random(3) + 1;
vy := random(4) + 1;
RNew := bounds(x, y, W, H);
ROld := RNew;
end;
end;
Timer1.interval := 1;
Timer1.enabled := true;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
i: integer;
begin
Fin := true;
BmpBkg.free;
BmpMoving.free;
for i := 0 to (nb - 1) do
Spheres[i].Bitm.Free;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
PaintBox1.Canvas.Draw(0, 0, BmpMoving);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
close;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
n, i: integer;
Runion: Trect;
begin
for n := 1 to trackbar1.position do
begin
if fin then exit;
for i := 0 to (nb - 1) do
begin
with Spheres[i] do
begin
BmpMoving.Canvas.CopyRect(ROld, bmpBkg.canvas, ROld);
if (x < -ImageWidth) or (x > bmpBkg.width - W + ImageWidth)
then
vx := -vx;
if (y < 0) or (y > bmpBkg.height - H) then
vy := -vy;
xx := xx + vx;
yy := yy + vy;
x := trunc(xx);
y := trunc(yy);
RNew := bounds(x, y, W, H);
BmpMoving.Canvas.Draw(x, y, Bitm);
UnionRect(RUnion, ROld, RNew);
PaintBox1.Canvas.CopyRect(RUnion, BmpMoving.Canvas,
RUnion);
ROld := RNew;
end;
end;
end;
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
Edit1.text := inttostr(trackbar1.position);
if trackbar1.position = 1 then
label2.visible := true
else
label2.visible := false;
end;
end.
this program is just the start of another more important
thanks
Your code is almost OK.
As far as I can see your problem is caused by not completely restoring the background before you draw the bitmaps at their new locations. You need to restore the old rects of all spheres before you draw the new ones. Also you need to collect the complete union of all new and old rects before you update to screen.
As a matter of taste, I would avoid the global variables and make them fields of the form. If you also make PictureStorage a method of the form, everything works.
The timer interval of 1 seems a bit of an overkill. I would set it to 1000 div 120 (120 FPS).
I would set doublebuffered to false, as you are already doing your own doublebuffering. Also I would move the form's OnPaint to the paintbox's OnPaint, but that doesn't seem to work for you.
Here is the replacement of the OnTimer event which should work (I checked an analogue with Delphi 2006, I don't have Delphi7 installed anymore and I don't know what the n means).
procedure TForm1.Timer1Timer(Sender: TObject);
var
n, i: integer;
Runion: TRect;
begin
//I don't know what the n-loop is for, in my test I left it out
for n := 1 to TrackBar1.position do
begin
//prevent reentry?
if fin then
exit;
// Restore the background completely
for i := 0 to (nb - 1) do
with Spheres[i] do
begin
BmpMoving.Canvas.CopyRect(ROld, BmpBkg.Canvas, ROld);
// Collect the old rects into the update-rect
if i = 0 then
Runion := ROld
else
UnionRect(Runion, Runion, ROld);
end;
for i := 0 to (nb - 1) do
with Spheres[i] do
begin
if (x < -ImageWidth) or (x > BmpBkg.width - W + ImageWidth) then
vx := -vx;
if (y < 0) or (y > BmpBkg.height - H) then
vy := -vy;
xx := xx + vx;
yy := yy + vy;
x := trunc(xx);
y := trunc(yy);
RNew := bounds(x, y, W, H);
BmpMoving.Canvas.Draw(x, y, Bitm);
// Add RNew to RUnion
UnionRect(Runion, Runion, RNew);
// No painting yet, update the screen as few times as possible
ROld := RNew;
end;
//Now update the screen
//This is the reliable way for sherlock to update the screen:
OffsetRect(RUnion, Paintbox1.left, Paintbox1.top);
//RUnion in form's coordinates
InvalidateRect(Handle, #RUnion, false);
//The following works for me just as well:
(**************
PaintBox1.Canvas.CopyRect(Runion, BmpMoving.Canvas, Runion);
***************)
end;
end;
This code can be commented out.
Tt does not affect the program :
// Collect the old rects into the update-rect
{ if i = 0 then
Runion := ROld
else
UnionRect(Runion, Runion, ROld); }

How to get volume level in current sample? Delphi 7

On Delphi 7 I am running this code with NewAC Audio library. I am having short wav file, 44.100 kHz, mono, 16 bit.
unit Main;
interface
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ACS_Classes, ACS_DXAudio, ACS_Wave, ACS_Misc, ACS_Types, StdCtrls;
type
TForm1 = class(TForm)
AudioProcessor1: TAudioProcessor;
WaveIn1: TWaveIn;
DXAudioOut1: TDXAudioOut;
OpenDialog1: TOpenDialog;
Button1: TButton;
Button2: TButton;
procedure AudioProcessor1GetData(
Sender: TComponent;
var Buffer: Pointer;
var NBlockBytes: Cardinal);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure DXAudioOut1Done(Sender: TComponent);
procedure AudioProcessor1Init(Sender: TComponent; var TotalSize: Int64);
procedure AudioProcessor1Flush(Sender: TComponent);
end;
var Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.AudioProcessor1GetData(Sender: TComponent;
var Buffer: Pointer; var NBlockBytes: Cardinal);
var Tmp : Integer;
i : Integer;
list1: TStringList;
list2: TStringList;
b1, b2, b3, b4:byte;
si1, si2, si3, si4: ShortInt;
mono: Boolean;
values: array of word;
begin
list1 := TStringList.Create;
list2 := TStringList.Create;
AudioProcessor1.Input.GetData(Buffer, NBlockBytes);
if Buffer = nil then
Exit;
mono := false;
case AudioProcessor1.Input.BitsPerSample of
16 :
begin
B16 := Buffer;
setlength(values, NBlockBytes div 2);
for i := 0 to (NBlockBytes div 4) - 1 do
begin
Tmp := B16[i*2];
move(B16[i*2], b1, 1); // copy left channel
move(B16[i*2+1], b2, 1); // copy right channel
move(B16[i*2+2], b3, 1); // copy left channel
move(B16[i*2+3], b4, 1); // copy right channel
si1 := b1;
si2 := b2;
si3 := b3;
si4 := b4;
list1.add(''+inttostr(si1));
list2.add(''+inttostr(si2));
list1.add(''+inttostr(si3));
list2.add(''+inttostr(si4));
B16[i*2] := B16[i*2 + 1];
B16[i*2 + 1] := Tmp;
end;
end;
end;
list1.free;
list2.free;
end;
procedure TForm1.AudioProcessor1Init(Sender: TComponent; var TotalSize: Int64);
begin
TAudioProcessor(Sender).Input.Init;
TotalSize := TAudioProcessor(Sender).Input.Size
end;
procedure TForm1.AudioProcessor1Flush(Sender: TComponent);
begin
TAudioProcessor(Sender).Input.Flush;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
Button1.Enabled := False;
WaveIn1.FileName := OpenDialog1.FileName;
DXAudioOut1.Run;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
DXAudioOut1.Stop;
end;
procedure TForm1.DXAudioOut1Done(Sender: TComponent);
begin
Button1.Enabled := True;
end;
end.
When I open the file in editing software I can see the amplitude of the sound and I see that the beginning values are 0. But when I run this program and I add the si1, si2, si3 and si4 to watch (in this order are the variables in watch), so I have these values in first iteration:
80,124,104,32.
I expected that these values should be 0 because there is silence on the begin.
First, may you explain why these are not zero?
Second, I am not sure what these values really represent. I know that si1 and si2 are first sample. But is it really level of the volume? How to correct the program to recognize the silence in the begin?
Tested file -> the section which should be passed to the function as first.
This part is not proccessed (because I processed only few cicles of the first loop):
I did some tests with file "silence plus", amplifications and see the first 8 cicles values.
Another test with word instead byte:
B16 := Buffer;
...
move(B16[i*2], w1, 2);
move(B16[i*2+1], w2, 2);
It really looks like the bits need to swap. I thought that in Windows XP I have little endian bit order. So I will write a swapper.
The main problems of my code were:
1) Reading 1 byte of sample instead 2 bytes of sample.
2) The sample is signed, not unsigned. So when I tried to read two bytes of word, I get wrong numbers (see the last table in question).
3) I also tried to use two bytes of SmallInt swapped, but that resulted to crazy numbers like -25345, -1281, 26624, -19968 ... This is because on my system I use Little endian (Windows XP). There is not need to swap it on Windows.
So the solution was to copy 16 bits to SmallInt, no swap.
unit Main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ACS_Classes, ACS_DXAudio, ACS_Wave, ACS_Misc, ACS_Types, StdCtrls;
type
TForm1 = class(TForm)
AudioProcessor1: TAudioProcessor;
WaveIn1: TWaveIn;
DXAudioOut1: TDXAudioOut;
OpenDialog1: TOpenDialog;
Button1: TButton;
Button2: TButton;
procedure AudioProcessor1GetData(
Sender: TComponent;
var Buffer: Pointer;
var NBlockBytes: Cardinal);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure DXAudioOut1Done(Sender: TComponent);
procedure AudioProcessor1Init(Sender: TComponent; var TotalSize: Int64);
procedure AudioProcessor1Flush(Sender: TComponent);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.AudioProcessor1GetData(Sender: TComponent;
var Buffer: Pointer; var NBlockBytes: Cardinal);
var
B16 : PBuffer16;
i, end_ : Integer;
si1, si2: SmallInt;
begin
AudioProcessor1.Input.GetData(Buffer, NBlockBytes);
if Buffer = nil then
Exit;
case AudioProcessor1.Input.BitsPerSample of
16 :
begin
B16 := Buffer;
end_ := (NBlockBytes div 2) - 1;
for i := 0 to end_ do
begin
move(B16[i*2], si1, 2);
move(B16[i*2+1], si2, 2);
end;
end;
end;
end;
procedure TForm1.AudioProcessor1Init(Sender: TComponent; var TotalSize: Int64);
begin
TAudioProcessor(Sender).Input.Init;
TotalSize := TAudioProcessor(Sender).Input.Size
end;
procedure TForm1.AudioProcessor1Flush(Sender: TComponent);
begin
TAudioProcessor(Sender).Input.Flush;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
Button1.Enabled := False;
WaveIn1.FileName := OpenDialog1.FileName;
DXAudioOut1.Run;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
DXAudioOut1.Stop;
end;
procedure TForm1.DXAudioOut1Done(Sender: TComponent);
begin
Button1.Enabled := True;
end;
end.
Here are the values:

How can I Create a Interactive Panel of Options Similar to TeamViewer (hide/show)?

I do not know how to call an interactive panel of tools like TeamViewer has. My question is very objective: How can I create a interactive panel where the panel will hide/show at any moment?
Example:
EDIT:
I found a possible solution (code below). Now I want to insert a "Button" glued on the right side and below Panel. How can I make this?
procedure TForm1.btn1Click(Sender: TObject);
begin
AnimateWindow(Panel1.Handle, 800, AW_SLIDE or AW_VER_NEGATIVE or AW_HIDE);
end;
procedure TForm1.btn2Click(Sender: TObject);
begin
AnimateWindow(Panel1.Handle, 800, AW_SLIDE or AW_VER_POSITIVE or AW_ACTIVATE);
end;
type
TForm1 = class(TForm)
pnl1: TPanel;
btn1: TButton;
procedure btn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.btn1Click(Sender: TObject);
begin
if btn1.Caption = 'H' then
begin
btn1.Top := 0;
btn1.Caption := 'S';
AnimateWindow(Pnl1.Handle, 400, AW_SLIDE or AW_VER_NEGATIVE or AW_HIDE);
end
else
begin
btn1.Top:= pnl1.Height;
btn1.Caption := 'H';
AnimateWindow(Pnl1.Handle, 400, AW_SLIDE or AW_VER_POSITIVE or AW_ACTIVATE);
end;
end;
end.
This was my solution:
I'm still using AnimateWindow api.
On Button properties, set right = 0
When Panel is visible, the Button have top := Panel.Height
By last, when Panel is no-visible (hidden), Button have top := 0
Try this:
unit NP;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TMainFrm = class(TForm)
Timer1: TTimer;
Timer2: TTimer;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
private
public
end;
var
MainFrm: TMainFrm;
Range: integer;
implementation
{$R *.dfm}
procedure TMainFrm.FormCreate(Sender: TObject);
begin
Width := 255;
Height := Screen.Height;
Left := 0 - Width;
Top := 0;
Range := 0;
Timer1.Enabled := True;
Timer2.Enabled := True;
MainFrm.Show;
end;
procedure TMainFrm.Timer1Timer(Sender: TObject);
var
pos: TPoint;
begin
GetCursorPos(pos);
if (pos.X < 10) and (MainFrm.Left < 0) then
begin
Range := 20;
MainFrm.Show;
end;
if (Range <> 0) then
MainFrm.Left := MainFrm.Left + Range;
if MainFrm.Left < 0 - MainFrm.Width then
begin
Range := 0;
MainFrm.Left := 0 - MainFrm.Width;
MainFrm.Hide;
end;
if (Range = 20) and (MainFrm.Left >= 0) then
begin
Range := 0;
MainFrm.Left := 0;
end;
end;
procedure TMainFrm.Timer2Timer(Sender: TObject);
var
pos: TPoint;
begin
GetCursorPos(pos);
if pos.X > MainFrm.Width then
Range := -20;
end;
end.
Axel

2 delphi questions, copying code and randomizing

I'm making my first program in delphi and it's a space invaders rip off. So I have 2 questions:
First off, how would I copy code to every single object? This is what I have now:
procedure TForm2.Timer1Timer(Sender: TObject);
begin
//Label2.Caption := IntToStr(Form2.ClientWidth);
//Label1.Caption := IntToStr(Shape2.Left + Shape2.Width);
if smer = 1 then begin
Shape2.Left:=Shape2.left+56;
Shape3.Left:=Shape3.left+56;
Shape4.Left:=Shape4.left+56;
Shape5.Left:=Shape5.left+56;
Shape6.Left:=Shape6.left+56;
if Shape6.Left+Shape6.Width>Form2.ClientWidth then begin
Shape2.Top:=Shape2.Top+56;
Shape3.Top:=Shape3.Top+56;
Shape4.Top:=Shape4.Top+56;
Shape5.Top:=Shape5.Top+56;
Shape6.Top:=Shape6.Top+56;
smer:=0;
end;
end;
if smer = 0 then begin
Shape2.Left:=Shape2.left-56;
Shape3.Left:=Shape3.left-56;
Shape4.Left:=Shape4.left-56;
Shape5.Left:=Shape5.left-56;
Shape6.Left:=Shape6.left-56;
if Shape2.Left<=0 then begin
Shape2.Top:=Shape2.Top+56;
Shape3.Top:=Shape3.Top+56;
Shape4.Top:=Shape4.Top+56;
Shape5.Top:=Shape5.Top+56;
Shape6.Top:=Shape6.Top+56;
smer:=1;
end;
end;
end;
procedure TForm2.Timer2Timer(Sender: TObject);
begin
if MetakP.Visible=true then begin
MetakP.Top:=MetakP.Top-11;
end;
if MetakN.Visible=true then begin
MetakN.Top:=MetakN.Top+11;
end;
if MetakN.Top>Form2.Height then MetakN.Visible:=false;
if MetakP.Top<=0 then begin
MetakP.Left:=Image1.Left+16;
MetakP.Top:=Image1.Top;
MetakP.visible:=false;
Let:=0;
end;
if (MetakN.left>=Image1.Left) or (MetakN.Left+MetakN.Width >= Image1.left) then begin // da li je metak desno od kocke
if MetakN.left<=Image1.Left+Image1.Width then begin // da li je metak levo od kocke
If MetakN.Top<=Image1.Top+Image1.Height then begin // da li je metak ispod kocke
if MetakN.Top>=Image1.Top-Image1.Height then begin
if MetakN.Visible=true then begin
Image1.Visible:=false;//
MetakN.Left:=Image1.Left+16;
MetakN.Top:=Image1.Top;
MetakN.visible:=false;
Let:=0;
gub:=gub+1;
//Image1.Enabled:=false;
end;
end;
end;
end;
end;
if (MetakP.left>=Shape2.Left) or (MetakP.Left+MetakP.Width >= Shape2.left) then begin // da li je metak desno od kocke
if MetakP.left<=Shape2.Left+Shape2.Width then begin // da li je metak levo od kocke
If MetakP.Top<=Shape2.Top+Shape2.Height then begin // da li je metak ispod kocke
if MetakP.Top>=Shape2.Top-Shape2.Height then begin
if Shape2.Visible=true then begin
Shape2.Visible:=false;//
MetakP.Left:=Image1.Left+16;
MetakP.Top:=Image1.Top;
MetakP.visible:=false;
Let:=0;
pob:=pob+1;
//Shape2.Enabled:=false;
end;
end;
end;
end;
end;
end;
This is continued for all shapes. It's basically a hitbox check. Now, that's a lot of code, is there a way I could make it work for all the shapes separately?
Second off, how would I fire off a bullet out of a random shape? I have:
procedure TForm2.Timer4Timer(Sender: TObject);
var r:integer;
var rr:string;
begin
MetakN.Visible:=true;
if Shape2.Visible=false then MetakN.Visible:=false;
r:=2+random(5);
rr:=IntToStr(r);
MetakN.Top:= Shape2.top+Shape2.Height;
MetakN.Left:= Shape2.Left+Shape2.Width div 2;
end;
The r was supposed to be used as "Shape[r].top" and so on, but it doesn't work.
Programs are made up of 2 parts.
Code
Data structures
You are only using 1.
You need to get a data structure to hold your Aliens.
Because it's just a bunch of aliens a list will work fine.
Add a variable to your form to put your aliens in.
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, System.Generics.Collections;
TForm1 = class(TForm)
....
private
Aliens: TList<TShape>;
You can initialize your shapes on form creation.
Something like this.
procedure TForm1.FormCreate(Sender: TObject);
var
i: integer;
AngryAlien: TShape;
begin
Aliens:= TList<TShape>.Create;
for i := 0 to 100 do begin
AngryAlien:= TShape.Create(Form1);
AngryAlien.Parent:= Form1;
AngryAlien.Shape:= stCircle;
AngryAlien.Brush.Color:= clWhite;
AngryAlien.Width:= 30;
AngryAlien.Height:= 30;
AngryAlien.Visible:= false;
Aliens.Add(AngryAlien);
end;
end;
Now you have a 100 101 aliens.
You can move the aliens around on a timer.
procedure TForm1.Timer1Timer(Sender: TObject);
var
i: integer;
Alien: TShape;
begin
//Move 4 aliens.
for i := 0 to 100 do begin
Alien:= Aliens[i];
Alien.Visible:= true;
Alien.Left:= Alien.Left + Random(30) - Random(20);
Alien.Top:= Alien.Top + Random(15) - Random(10);
end;
end;
Now you just use a loop to control every alien in turn.
If you want some game sample code, here something to get you started: http://delphi.about.com/od/gameprogramming/
More specifically: http://delphi.about.com/library/code/fdac_dodge_src.zip
Of course the above code is a bad example of copy-paste anti pattern and I would rewrite it like so:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
shp_player: TShape;
shp_enemy: TShape;
btnStart: TButton;
timercircle: TTimer;
shparea: TShape;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Edit1: TEdit;
Label5: TLabel;
Shape1: TShape;
Lbl_player: TLabel;
lbl_circle: TLabel;
lbl_enemy: TLabel;
procedure FormCreate(Sender: TObject);
procedure btnStartClick(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure timercircleTimer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
type
//my own category of variables
TLevelArray = Array [1 .. 30] of Boolean;
var
circle: array [1 .. 30] of TShape;
Speedx: array [1 .. 30] of Integer;
Speedy: array [1 .. 30] of Integer;
Level: array [1..30] of TLevelArray;
SpeedxCalculation: Integer;
SpeedyCalculation: Integer;
LevelStore: Integer = 1;
HighScore: Boolean = False;
procedure ShowCircles(Level: TLevelArray);
var
Count: Integer;
begin
for Count:= 1 to 30 do begin
circle[Count].Visible:= Level[Count];
end;
end;
procedure InitLevels;
var
i,j: integer;
begin
for i := 1 to 30 do begin
FillChar(Level[i], SizeOf(Level[i]),#0);
end;
for i := 1 to 30 do begin
for j := 1 to i do begin
Level[i][j]:= true;
end;
end;
end;
procedure Updatecircles; //if the circle needs to be visible for that level
var
Count: Integer;
begin
for Count:= 1 to 30 do begin
ShowCircles(Level[LevelStore]);
end;
end;
Procedure SpeedCalculation;
begin
circle[LevelStore].Left:= 8; //all the circles come from the same position
circle[LevelStore].Top:= 8;
repeat
Randomize; //their speeds are random for more interesting gameplay
SpeedxCalculation:= Random(10) + 1;
Speedx[LevelStore]:= 5 - SpeedxCalculation;
Randomize;
SpeedyCalculation:= Random(10) + 1;
Speedy[LevelStore]:= 5 - SpeedyCalculation;
until (speedy[LevelStore]) and (Speedx[LevelStore]) <> 0;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Count: Integer;
i: integer;
MyCircle: TShape;
begin
InitLevels;
for i := 1 to 30 do begin
MyCircle:= TShape.Create(Self);
MyCircle.Parent:= Self;
MyCircle.Width:= 10;
MyCircle.Height:= 10;
MyCircle.Brush.Color:= clmaroon;
MyCircle.Visible:= false;
MyCircle[i]:= MyCircle;
end;
Randomize;
shp_enemy.Left:= Random(clientwidth) - shp_enemy.width;
shp_enemy.Top:= Random(clientheight) - shp_enemy.height;
lbl_enemy.Left:= shp_enemy.Left;
lbl_enemy.Top:= shp_enemy.Top - 20;
SpeedCalculation;
updatecircles;
end;
procedure TForm1.btnStartClick(Sender: TObject);
begin
TimerCircle.enabled:= True;
btnStart.Visible:= False;
Label2.Caption:= '0';
Edit1.enabled:= False;
lbl_player.Visible:= False;
lbl_enemy.Visible:= False;
lbl_circle.Visible:= False;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
shp_player.Left:= x - shp_player.Width - 10;
shp_player.Top:= y - shp_player.Height - 10; //the green block follows the mouse
lbl_player.Left:= x - lbl_player.Width - 10;
lbl_player.Top:= y - lbl_player.Height - 30;
end;
procedure TForm1.timercircleTimer(Sender: TObject);
var
overlay: Trect;
Count: Integer;
begin
for Count:= 1 to LevelStore do begin
// Moves the circles
circle[Count].Left:= circle[Count].Left + speedx[Count];
circle[Count].Top:= circle[Count].Top + speedy[Count];
//bounces the circles off of the boundaries of the form
if circle[Count].Left > clientwidth - circle[Count].width then speedx[Count]:= -speedx[Count]
else if circle[Count].Left < 0 then speedx[Count]:= -speedx[Count];
if circle[Count].Top > clientheight - circle[Count].Height then speedy[Count]:= -speedy[Count]
else if circle[Count].Top < 0 then speedy[Count]:= -speedy[Count];
//detects a collision between a circle and the players block
if Intersectrect(overlay, circle[Count].BoundsRect, shp_player.BoundsRect) then begin
c1.Left:= 8;
c1.Top:= 8;
btnstart.caption:= 'Restart';
btnstart.Visible:= True;
LevelStore:= 1;
SpeedCalculation;
UpdateCircles;
timercircle.enabled:= false;
if HighScore = True then //if a new high score has been achieved
begin
Edit1.Enabled:= True;
HighScore:= False;
end;
lbl_player.Visible:= True;
lbl_enemy.Visible:= True;
lbl_circle.Visible:= True;
lbl_enemy.Left:= shp_enemy.Left;
lbl_enemy.Top:= shp_enemy.Top - 20;
end;
//detects a collision between the player block and target block
if Intersectrect(overlay, shp_enemy.BoundsRect, shp_player.BoundsRect) then begin
Label2.Caption:= inttostr(strtoint(Label2.Caption) + 1);
if strtoint(Label2.Caption) > strtoint(Label4.Caption) then begin
highscore:= True;
Label4.Caption:= Label2.Caption;
end;
Randomize;
repeat
//the target block goes to a new position on the form
shp_enemy.Left:= Random(clientwidth) + 2 * (shp_enemy.width);
shp_enemy.Top:= Random(clientheight) - 2 * (shp_enemy.height);
until ((shp_enemy.Left) > (Form1.Left + shp_enemy.Width)) and
((shp_enemy.Left) < (Form1.Left + clientwidth - 2 * (shp_enemy.Width))) and
((shp_enemy.Top) > (Form1.Top + shp_enemy.Height)) and
((shp_enemy.Top) < (Form1.Top + clientwidth - 2 * (shp_player.Width)));
LevelStore:= LevelStore + 1;
if LevelStore = 30 then // there are only 30 circles
begin
MessageDlg('Congratulations! - You have completed the game!', mtinformation, [mbOK], 0);
timercircle.enabled:= false;
btnstart.Visible:= True;
LevelStore:= 1;
SpeedCalculation;
UpdateCircles;
end else begin
SpeedCalculation;
UpdateCircles;
end;
end;
end;
end;
end.//FIN - Code by Si (c)
That way you don't repeat yourself.

Memory Leak in Complete Delphi Code using a tlist

Attached is complete code for a memory leak example I am running into. Can some one please advise me as to how to clean up this memory leak. This code can be compiled if you create a form and drop a button on it and then paste in the below code into the .pas file. Thanks in advance for any help that can be provided.
unit LeakForm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type PrintRecord = record
PrintString1,
PrintString2,
PrintString3,
PrintString4,
PrintString5,
PrintString6 : string;
PrintFloat1,
PrintFloat2,
PrintFloat3 : Double;
end;
PrintPointer = ^PrintRecord;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
MyPrintLst : TList;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure ClearTList(Var List : TList);
Var I, Count : Integer;
begin
Count := list.Count - 1;
For I := Count DownTo 0 Do
Dispose(List[I]);
List.Clear;
end;
procedure FreeTList(Var List : TList);
Var I, Count : Integer;
begin
ClearTList(List);
List.Free;
end;
procedure AddToPrintList(PrintList : TList;
Const MyStrings : Array of String;
Const MyDoubles : Array of Double);
var
PrintPtr : PrintPointer;
begin
New(PrintPtr);
IF High(MyStrings) >= 0 Then
PrintPtr^.printString1 := MyStrings[0];
Begin
IF High(MyStrings) >= 1 Then
Begin
PrintPtr^.printString2 := MyStrings[1];
IF High(MyStrings) >= 2 Then
Begin
PrintPtr^.printString3 := MyStrings[2];
IF High(MyStrings) >= 3 Then
Begin
PrintPtr^.printString4 := MyStrings[3];
IF High(MyStrings) >= 4 Then
PrintPtr^.printString5 := MyStrings[4];
Begin
IF High(MyStrings) >= 5 Then
PrintPtr^.printString6 := MyStrings[5];
End; {>=5}
End; {>=4}
End; {>=3}
End; {>=2}
End; {>=1}
IF High(MyDoubles) >= 0 Then
Begin
PrintPtr^.PrintFloat1 := MyDoubles[0];
IF High(MyDoubles) >= 1 Then
Begin
PrintPtr^.PrintFloat2 := MyDoubles[1];
IF High(MyDoubles) >= 2 Then
PrintPtr^.PrintFloat3 := MyDoubles[2];
End;
End;
PrintList.add(PrintPtr);
end;
procedure TForm1.Button1Click(Sender: TObject);
Var EstReading : LongInt;
begin
EstReading := 0;
ClearTList(MyPrintLst);
AddToPrintList(MyPrintLst, ['Field1 Data','Field2 Data','Field3 Data','Field4 Data'],
[1,2,3,4]);
AddToPrintList(MyPrintLst, ['Field1 Data','Field2 Data','Field3 Data','Field4 Data'],
[5,6,7,8]);
AddToPrintList(MyPrintLst, ['Field1 Data','Field2 Data','Field3 Data','Field4 Data'],
[9,0,1,2]);
AddToPrintList(MyPrintLst, ['Field1 Data','Field2 Data','Field3 Data','Field4 Data'],
[3,4,5,6]);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
MyPrintLst := TList.Create;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FreeTList(MyPrintLst);
end;
end.
When you dispose each item, the runtime needs to know the type of the record. Because you are using a TList then each item is an untyped pointer. Therefore you need to cast the pointers to the item type so that the runtime knows the type, and knows how to dispose of the item.
Replace
Dispose(List[I]);
with
Dispose(PrintPointer(List[I]));
It's also a little odd that you pass the list as a var parameter and do not modify the reference. And the loop is quite odd too, running backwards for no reason, and the loop bounds are handled in a strange manner. I'd have these functions like this:
procedure ClearTList(List: TList);
Var
I: Integer;
begin
For I := 0 to List.Count - 1 Do
Dispose(PrintPointer(List[I]));
List.Clear;
end;
procedure FreeTList(List: TList);
begin
ClearTList(List);
List.Free;
end;
A more conventional naming convention would be:
type
TPrintRecord = record
....
end;
PPrintRecord = ^TPrintRecord;
The form's OnClose event can be called multiple times if the form has the caHide action when closing. The correct event to pair with OnCreate is OnDestroy.
The complexity of the logic in AddToPrintList makes me believe that the data types can be designed in a better way. Arrays suggest themselves instead of individual numbered fields.
Without changing the types, you should at least avoid all that indentation, like this:
procedure AddToPrintList(PrintList: TList; const MyStrings: array of String;
const MyDoubles: array of Double);
var
I: Integer;
Item: PPrintRecord;
Str: string;
Value: Double;
begin
New(Item);
PrintList.Add(Item);
for I := 1 to Min(Length(MyStrings), 6) do
begin
Str := MyStrings[I - 1];
case I of
1:
Item.PrintString1 := Str;
2:
Item.PrintString2 := Str;
3:
Item.PrintString3 := Str;
4:
Item.PrintString4 := Str;
5:
Item.PrintString5 := Str;
6:
Item.PrintString6 := Str;
end;
end;
for I := 1 to Min(Length(MyDoubles), 3) do
begin
Value := MyDoubles[I - 1];
case I of
1:
Item.PrintFloat1 := Value;
2:
Item.PrintFloat2 := Value;
3:
Item.PrintFloat3 := Value;
end;
end;
end;

Resources