TTeeGrid at runtime creation gets slower as the number of columns increases - delphi

I am creating TTeeGrid (TDataSet descendant) at runtime supplied by API. I noticed that as the number of columns increases, the performance decreases. Meaning, the time of creating TTeeGrid is getting slower.
I am developing firemonkey app here and the performance is noticeable in iOS and Android when it reach to 20 columns or more.
Here's my code:
procedure TformMain.btnCreateTeeGridClick(Sender: TObject);
begin
FreeAndNil(CanvassGrid); // delete the old grid
// create a new grid
CanvassGrid := TTeeGrid.Create(recCanvass);
With CanvassGrid do
begin
Parent := recCanvass;
Align := TAlignLayout.Client;
Margins.Top := 5;
Margins.Left := 5;
Margins.Right := 5;
Margins.Bottom := 5;
ScrollBars.Visible := True;
Header.Format.Font.Size := 11;
Cells.Format.Font.Size := 11;
TabOrder := 0;
ScrollBars.Visible := False;
end;
end;
Is there a way that I can improve the performance or did I missed something in my code that causes the performance to slow?
UPDATE 1: Minimal Reproducible Example
FMX File
object Form9: TForm9
Left = 0
Top = 0
Caption = 'MRE TeeGrid Runtime'#13#10
ClientHeight = 480
ClientWidth = 294
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
DesignerMasterStyle = 0
object btn1: TButton
Align = Bottom
Position.Y = 440.000000000000000000
Size.Width = 294.000000000000000000
Size.Height = 40.000000000000000000
Size.PlatformDefault = False
TabOrder = 9
Text = 'CREATE TEEGRID'
OnClick = btn1Click
end
object aniSearchProcess: TAniIndicator
Position.X = 128.000000000000000000
Position.Y = 216.000000000000000000
end
object lyt1: TLayout
Align = Client
Size.Width = 294.000000000000000000
Size.Height = 440.000000000000000000
Size.PlatformDefault = False
TabOrder = 11
end
object cur1: TFDGUIxWaitCursor
Provider = 'FMX'
Left = 32
Top = 32
end
object dvr1: TFDPhysSQLiteDriverLink
Left = 88
Top = 32
end
object con1: TFDConnection
Params.Strings = (
'DriverID=SQLite')
Connected = True
LoginPrompt = False
Left = 144
Top = 32
end
object loc1: TFDLocalSQL
Connection = con1
Active = True
Left = 200
Top = 32
end
object rsc1: TRESTClient
Accept = 'application/json, text/plain; q=0.9, text/html;q=0.8,'
AcceptCharset = 'utf-8, *;q=0.8'
BaseURL =
'https://me6hwinr2k.execute-api.ap-southeast-1.amazonaws.com/v0/d' +
'bqueries?item-var=9&qty=25'
Params = <>
Left = 32
Top = 112
end
object rsq1: TRESTRequest
Client = rsc1
Params = <>
Response = rsp1
SynchronizedEvents = False
Left = 32
Top = 176
end
object rsp1: TRESTResponse
ContentType = 'application/json'
Left = 32
Top = 240
end
object rsd1: TRESTResponseDataSetAdapter
Active = True
Dataset = mtb1
FieldDefs = <>
Response = rsp1
Left = 32
Top = 304
end
object mtb1: TFDMemTable
Active = True
FieldDefs = <
item
Name = 'Category'
DataType = ftWideString
Size = 255
end
item
Name = 'ID'
DataType = ftWideString
Size = 255
end
item
Name = 'Item'
DataType = ftWideString
Size = 255
end
item
Name = 'Qty'
DataType = ftWideString
Size = 255
end
item
Name = 'Container'
DataType = ftWideString
Size = 255
end
item
Name = 'Size'
DataType = ftWideString
Size = 255
end
item
Name = 'Ex temporibus dolore consequatur.'
DataType = ftWideString
Size = 255
end
item
Name = 'Et cum aut est nostrum...'
DataType = ftWideString
Size = 255
end
item
Name = 'Sequi quibusdam eum.'
DataType = ftWideString
Size = 255
end>
IndexDefs = <>
FetchOptions.AssignedValues = [evMode]
FetchOptions.Mode = fmAll
ResourceOptions.AssignedValues = [rvSilentMode]
ResourceOptions.SilentMode = True
UpdateOptions.AssignedValues = [uvCheckRequired, uvAutoCommitUpdates]
UpdateOptions.CheckRequired = False
UpdateOptions.AutoCommitUpdates = True
StoreDefs = True
Left = 32
Top = 368
end
end
FMX Procedures
unit Main;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
FireDAC.UI.Intf, FireDAC.FMXUI.Wait, FireDAC.Stan.ExprFuncs,
FireDAC.Phys.SQLiteDef, FireDAC.Stan.Intf, FireDAC.Stan.Option,
FireDAC.Stan.Error, FireDAC.Phys.Intf, FireDAC.Stan.Def, FireDAC.Stan.Pool,
FireDAC.Stan.Async, FireDAC.Phys, FireDAC.Phys.SQLite, Data.DB,
FireDAC.Stan.Param, FireDAC.DatS, FireDAC.DApt.Intf, REST.Types,
FMX.Controls.Presentation, FMX.StdCtrls, FireDAC.Comp.DataSet,
FireDAC.Comp.Client, REST.Response.Adapter, REST.Client, Data.Bind.Components,
Data.Bind.ObjectScope, FireDAC.Phys.SQLiteVDataSet, FireDAC.Comp.UI,
FMXTee.Control, FMXTee.Grid, FMX.Layouts;
type
TForm9 = class(TForm)
cur1: TFDGUIxWaitCursor;
dvr1: TFDPhysSQLiteDriverLink;
con1: TFDConnection;
loc1: TFDLocalSQL;
rsc1: TRESTClient;
rsq1: TRESTRequest;
rsp1: TRESTResponse;
rsd1: TRESTResponseDataSetAdapter;
mtb1: TFDMemTable;
btn1: TButton;
aniSearchProcess: TAniIndicator;
lyt1: TLayout;
procedure btn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form9: TForm9;
tgd1: TTeeGrid;
implementation
{$R *.fmx}
procedure TForm9.btn1Click(Sender: TObject);
var
i, CanvassItemId, e : Integer;
begin
aniSearchProcess.Visible := True;
aniSearchProcess.Enabled := True;
{$IFDEF MSWINDOWS}
Application.ProcessMessages;
{$ENDIF}
{$IF DEFINED(iOS) or DEFINED(ANDROID)}
Application.HandleMessage;
{$ENDIF}
FreeAndNil(tgd1); //free old grid
//create new grid
tgd1 := TTeeGrid.Create(lyt1);
With tgd1 do
begin
Parent := lyt1;
Align := TAlignLayout.Client;
Margins.Top := 5;
Margins.Left := 5;
Margins.Right := 5;
Margins.Bottom := 5;
ScrollBars.Visible := True;
Header.Format.Font.Size := 11;
Cells.Format.Font.Size := 11;
TabOrder := 0;
ScrollBars.Visible := False;
end;
con1.StartTransaction;
try
//define the API here for duplicate/update, initial click and subsequent clicks
rsc1.BaseURL := ...;
rsq1.Execute;
rsd1.Active := True;
mtb1.Active;
tgd1.DataSource := mtb1;
tgd1.Enabled := True;
// adjust the column properties dynamically
with tgd1 do
begin
for i := 0 to Columns.Count -1 do
begin
if i = 0 then
begin
Columns[i].Visible := False; // category column
end
else if (i = 1) then
begin
Columns[i].Visible := False; // id column
end
else if (i = 2) then
begin
Columns[i].Width.Value := 120; // item column
end
else if (i = 3) then
begin
Columns[i].Width.Value := 30; // qty column
end
else if (i = 4) then
begin
Columns[i].Width.Value := 50; // container column
end
else if (i = 5) then
begin
Columns[i].Width.Value := 50; // size column
end
else
begin
Columns[i].Width.Value := 50; // subsequent random columns
end;
end;
end;
finally
con1.Commit;
end;
aniSearchProcess.Visible := False;
aniSearchProcess.Enabled := False;
{$IFDEF MSWINDOWS}
Application.ProcessMessages;
{$ENDIF}
{$IF DEFINED(iOS) or DEFINED(ANDROID)}
Application.HandleMessage;
{$ENDIF}
end;
end.

Related

FMX: How to draw a bitmap with reduced size and high quality?

I notice that quality of images is poor when drawn smaller than the source image. This is especially obvious when the image contains thin lines as the subsampling causes parts of the lines to disappear. I'm looking for a way to improve the quality without compromising too much on runtime. So ideally I'd like it to be done on the GPU. Below is an example with 3 different methods. The last method is my own code, which shows what I'm trying to achieve but is not done on the GPU and so is too slow. It also won't work if I want to include some rotation as well as scale. I have also tried changing the HighSpeed flag in the DrawBitmap function, but it doesn't seem to make a difference.
Form:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 240
ClientWidth = 438
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
DesignerMasterStyle = 0
object Image1: TImage
MultiResBitmap = <
item
end>
Position.X = 8.000000000000000000
Position.Y = 8.000000000000000000
end
object Image2: TImage
MultiResBitmap = <
item
end>
Position.X = 216.000000000000000000
Position.Y = 8.000000000000000000
end
object Image3: TImage
MultiResBitmap = <
item
end>
Position.X = 216.000000000000000000
Position.Y = 80.000000000000000000
end
object Image4: TImage
MultiResBitmap = <
item
end>
Position.X = 216.000000000000000000
Position.Y = 152.000000000000000000
end
object Label1: TLabel
Position.X = 266.000000000000000000
Position.Y = 24.000000000000000000
Size.Width = 164.000000000000000000
Size.Height = 17.000000000000000000
Size.PlatformDefault = False
Text = 'Scale destination rectangle'
TabOrder = 6
end
object Label2: TLabel
Position.X = 266.000000000000000000
Position.Y = 96.000000000000000000
Size.Width = 164.000000000000000000
Size.Height = 17.000000000000000000
Size.PlatformDefault = False
Text = 'Create canvas scale transform'
TabOrder = 5
end
object Label3: TLabel
Position.X = 266.000000000000000000
Position.Y = 168.000000000000000000
Size.Width = 164.000000000000000000
Size.Height = 17.000000000000000000
Size.PlatformDefault = False
Text = 'Hand coded Shrink function'
TabOrder = 4
end
end
Unit:
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Objects,
FMX.Controls.Presentation, FMX.StdCtrls;
type
PAlphaColorArray = ^TAlphaColorArray;
TAlphaColorArray = array[0..32767] of TAlphaColor;
TForm1 = class(TForm)
Image1: TImage;
Image2: TImage;
Image3: TImage;
Image4: TImage;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
procedure Shrink(const ABitmap : TBitmap ; out ABitmapOut : TBitmap);
var
Form1: TForm1;
implementation
uses Math, Math.Vectors;
{$R *.fmx}
procedure TForm1.FormCreate(Sender: TObject);
const
r : Single = 0.2;
size : Integer = 200;
var
srcRect, dstRect : TRectF;
bmp : TBitmap;
begin
// Create source image - circle
Image1.Bitmap.BitmapScale := 1;
Image1.Bitmap.SetSize(size, size);
Image1.Width := Image1.Bitmap.Width;
Image1.Height := Image1.Bitmap.Height;
if Image1.Bitmap.Canvas.BeginScene then begin
Image1.Bitmap.Canvas.Clear(TAlphaColorRec.White);
Image1.Bitmap.Canvas.Stroke.Thickness := 1;
Image1.Bitmap.Canvas.DrawEllipse(TRectF.Create(size/10,size/10,9*size/10,9*size/10), 1);
Image1.Bitmap.Canvas.EndScene;
end;
srcRect := Image1.Bitmap.BoundsF;
dstRect := srcRect;
dstRect.BottomRight := PointF(dstRect.Width*r, dstRect.Height*r);
// Try reducing by scaling the destination rectangle
// Same method as TBitmap.CreateThumbnail
Image2.Bitmap.BitmapScale := 1;
Image2.Bitmap.SetSize(Ceil(dstRect.Width), Ceil(dstRect.Height));
Image2.Width := Image2.Bitmap.Width;
Image2.Height := Image2.Bitmap.Height;
if Image2.Bitmap.Canvas.BeginScene then begin
Image2.Bitmap.Canvas.DrawBitmap(Image1.Bitmap, srcRect, dstRect, 1, True);
Image2.Bitmap.Canvas.EndScene;
end;
// Try reducing using the canvas transform matrix
Image3.Bitmap.BitmapScale := 1;
Image3.Bitmap.SetSize(Ceil(dstRect.Width), Ceil(dstRect.Height));
Image3.Width := Image2.Bitmap.Width;
Image3.Height := Image2.Bitmap.Height;
if Image3.Bitmap.Canvas.BeginScene then begin
Image3.Bitmap.Canvas.SetMatrix(TMatrix.CreateScaling(r, r));
Image3.Bitmap.Canvas.DrawBitmap(Image1.Bitmap, srcRect, srcRect, 1, True);
Image3.Bitmap.Canvas.EndScene;
end;
// Reduce using Shrink function - Slow (not done on GPU)
bmp := TBitmap.Create(Ceil(dstRect.Width), Ceil(dstRect.Height));
bmp.BitmapScale := 1;
Image4.Width := bmp.Width;
Image4.Height := bmp.Height;
Shrink(Image1.Bitmap, bmp);
Image4.Bitmap.Assign(bmp);
bmp.Free;
end;
// Shrink a bitmap using all available data from source
// Could be sped up a little for specific cases such as scaling by 0.5
procedure Shrink(const ABitmap : TBitmap ; out ABitmapOut : TBitmap);
Var
Lx, Ly : integer;
LyBox, LxBox, LyBox1, LyBox2, LxBox1, LxBox2 : integer;
TR, TG, TB, TA : integer;
LRowIn, LRowOut, LRowInStart : PAlphaColorArray;
LBoxCount : integer;
LRowBytes, LRowBytesIn : integer;
LBoxRows : array of PAlphaColorArray;
LRatioW, LRatioH : Real;
bdata, bdatao : TBitmapData;
begin
if (ABitmapOut.Width = 0) or (ABitmapOut.Height = 0) then Exit;
LRatioH := ABitmap.Height / ABitmapOut.Height;
LRatioW := ABitmap.Width / ABitmapOut.Width;
ABitmap.Map(TMapAccess.Read, bdata);
ABitmapOut.Map(TMapAccess.Write, bdatao);
try
SetLength(LBoxRows, Trunc(LRatioH)+1);
LRowOut := PAlphaColorArray(bdatao.GetScanline(0));
LRowBytes := bdatao.Pitch;
LRowBytesIn := bdata.Pitch;
LRowInStart := PAlphaColorArray(bdata.GetScanline(0));
for Ly := 0 to ABitmapOut.Height-1 do begin
LyBox1 := Trunc(Ly*LRatioH);
LyBox2 := Trunc((Ly+1)*LRatioH) - 1;
for LyBox := LyBox1 to LyBox2 do
PByte(LBoxRows[LyBox-LyBox1]) := PByte(LRowInStart) + LyBox*LRowBytesIn;
for Lx := 0 to ABitmapOut.Width-1 do begin
LxBox1 := Trunc(Lx*LRatioW);
LxBox2 := Trunc((Lx+1)*LRatioW) - 1;
TR := 0; TG := 0; TB := 0; TA := 0;
LBoxCount := 0;
for LyBox := LyBox1 to LyBox2 do begin
LRowIn := LBoxRows[LyBox-LyBox1];
for LxBox := LxBox1 to LxBox2 do begin
Inc(TB, TAlphaColorRec(LRowIn[LxBox]).B);
Inc(TG, TAlphaColorRec(LRowIn[LxBox]).G);
Inc(TR, TAlphaColorRec(LRowIn[LxBox]).R);
Inc(TA, TAlphaColorRec(LRowIn[LxBox]).A);
Inc(LBoxCount);
end;
end;
TAlphaColorRec(LRowOut[Lx]).B := TB div LBoxCount;
TAlphaColorRec(LRowOut[Lx]).G := TG div LBoxCount;
TAlphaColorRec(LRowOut[Lx]).R := TR div LBoxCount;
TAlphaColorRec(LRowOut[Lx]).A := TA div LBoxCount;
end;
Inc(PByte(LRowOut), LRowBytes);
end;
finally
ABitmap.Unmap(bdata);
ABitmapOut.Unmap(bdatao);
end;
end;
end.

FMX Custom Header for TStringGrid

I am using this code to set the column Headers for my TStringGrid (FMX - 10.4.1)
procedure TForm1.StringGrid1ApplyStyleLookup(Sender: TObject);
var
Header: THeader;
HeaderItem: THeaderItem;
I: Integer;
begin
Header:= THeader((Sender as TStringGrid).FindStyleResource('header'));
if Assigned(Header) then
begin
for I := 0 to pred(Header.Count) do
begin
HeaderItem:= Header.Items[I];
HeaderItem.StyledSettings := HeaderItem.StyledSettings - [TStyledSetting.Size, TStyledSetting.FontColor];
HeaderItem.Font.Size := 20;
HeaderItem.FontColor:= TAlphaColors.Blue;
HeaderItem.TextSettings.HorzAlign := TTextAlign.Center;
HeaderItem.TextSettings.VertAlign := TTextAlign.Center;
end;
Header.Height := 28;
end;
end;
I get this result as expected
However, if I'm updating the list with some new data, the header is back to default style
Why is it different now? Why ApplyStyleLookup is applied only once ?
How can I make sure the correct settings will be applied to my headers each and every time ?
Thanks
Here below a sample code
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 400
ClientWidth = 600
Position = DesktopCenter
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
DesignerMasterStyle = 0
object StringGrid1: TStringGrid
Align = Client
CanFocus = True
ClipChildren = True
Margins.Left = 5.000000000000000000
Margins.Top = 50.000000000000000000
Margins.Right = 5.000000000000000000
Margins.Bottom = 5.000000000000000000
Size.Width = 590.000000000000000000
Size.Height = 345.000000000000000000
Size.PlatformDefault = False
StyleLookup = 'gridstyle'
TabOrder = 0
RowCount = 0
Options = [ColumnResize, ColLines, RowLines, RowSelect, Tabs, Header]
OnApplyStyleLookup = StringGrid1ApplyStyleLookup
Viewport.Width = 586.000000000000000000
Viewport.Height = 320.000000000000000000
object StringColumn1: TStringColumn
Header = 'Test'
end
end
object Button1: TButton
Position.X = 8.000000000000000000
Position.Y = 8.000000000000000000
Size.Width = 177.000000000000000000
Size.Height = 33.000000000000000000
Size.PlatformDefault = False
TabOrder = 1
Text = 'Show Form Properties'
OnClick = Button1Click
end
object Text1: TText
Anchors = [akLeft, akTop, akRight]
Position.X = 192.000000000000000000
Position.Y = 8.000000000000000000
Size.Width = 401.000000000000000000
Size.Height = 33.000000000000000000
Size.PlatformDefault = False
Text = 'Unkown'
TextSettings.HorzAlign = Trailing
end
end
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
System.Rtti, System.TypInfo,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Grid.Style,
FMX.StdCtrls, FMX.Controls.Presentation, FMX.ScrollBox, FMX.Grid, FMX.Header,
FMX.Objects;
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
Button1: TButton;
Text1: TText;
StringColumn1: TStringColumn;
procedure Button1Click(Sender: TObject);
procedure StringGrid1ApplyStyleLookup(Sender: TObject);
private
{ Private declarations }
FCount: cardinal;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
procedure TForm1.Button1Click(Sender: TObject);
var
PropList: PPropList;
PropCount, PropIndex: Integer;
begin
StringGrid1.ClearColumns;
PropCount:= GetPropList(Form1, PropList);
StringGrid1.RowCount:= PropCount;
StringGrid1.RowHeight:= 20;
StringGrid1.AddObject(TStringColumn.Create(StringGrid1));
StringGrid1.Columns[0].Width:= (StringGrid1.Width - 24) / 2;
StringGrid1.Columns[0].HorzAlign:= TTextAlign.Leading;
StringGrid1.Columns[0].Header:= 'Property';
StringGrid1.AddObject(TStringColumn.Create(StringGrid1));
StringGrid1.Columns[1].Width:= (StringGrid1.Width - 24) / 2;
StringGrid1.Columns[1].HorzAlign:= TTextAlign.Leading;
StringGrid1.Columns[1].Header:= 'Value';
for PropIndex:= 0 to pred(PropCount) do
begin
StringGrid1.Cells[0, PropIndex]:= PropList[PropIndex].Name;
StringGrid1.Cells[1, PropIndex]:= GetPropValue(Form1, PropList[PropIndex].Name, true);
end;
end;
procedure TForm1.StringGrid1ApplyStyleLookup(Sender: TObject);
var
Header: THeader;
HeaderItem: THeaderItem;
I: Integer;
begin
inc(FCount);
Text1.Text:= Format('Executed [%.3d]', [FCount]);
Header:= THeader((Sender as TStringGrid).FindStyleResource('header'));
if Assigned(Header) then
begin
for I := 0 to pred(Header.Count) do
begin
HeaderItem:= Header.Items[I];
HeaderItem.StyledSettings := HeaderItem.StyledSettings - [TStyledSetting.Size, TStyledSetting.FontColor];
HeaderItem.Font.Size := 20;
HeaderItem.FontColor:= TAlphaColors.Blue;
HeaderItem.TextSettings.HorzAlign := TTextAlign.Center;
HeaderItem.TextSettings.VertAlign := TTextAlign.Center;
end;
Header.Height := 28;
end;
end;
end.
I can not answer "why" questions, otherwise than "by design".
But to solve your problem, call
StringGrid1.NeedStyleLookup;
after you have made your changes to the structure (number of columns / rows) of the grid.
To personnalise the header of a grid in a FireMonkey project, you can use onDrawColumnHeader event (if you prefer to draw on the Canvas) or use styles.
In the form editor, on your grid, use context menu to "change default style" or "change personalised style".
The header is in "grid style / background / header" for the text.
To personnalise the background, create a new "headeritemstyle" element (try TLayout with no HitTest), add a "background" to it (TButtonStyle, TRectangle or other) aligned as Contents with no HitTest and a TText component with StyleName "text", HitTest to False and aligned to client. You also can manage it's behaviour directly from this style element.

Delphi FMX: Saving and loading container children

Starting from this layout at design time.
(It contains several TLayout, TGridPanelLayout, TText elements as example)
At runtime, I am saving the complete objects structure to a file using ObjectBinaryToText
But when loading the file back from the file using ObjectTextToBinary, I get this result
Why the sub-controls are not taking the exqct same layout as saved before?
The file structure seems to be OK and containing all sub-controls as described when saving my form with the IDE
Here is a piece of code demonstrating the problem.
PAS File
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes,
system.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics,
FMX.Dialogs, FMX.Objects, FMX.Layouts, FMX.Controls.Presentation,
FMX.StdCtrls;
type
TForm1 = class(TForm)
RecTop: TRectangle;
ButtonSave: TButton;
ButtonClear: TButton;
ButtonLoad: TButton;
Layout1: TLayout;
GridPanelLayout1: TGridPanelLayout;
Text1: TText;
Text2: TText;
Text3: TText;
Text4: TText;
procedure ButtonSaveClick(Sender: TObject);
procedure ButtonClearClick(Sender: TObject);
procedure ButtonLoadClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
AppPath: string;
AppDatFile: String;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
uses
System.IOUtils;
procedure TForm1.ButtonSaveClick(Sender: TObject);
var
FileStream : TFileStream;
MemStream : TMemoryStream;
begin
FileStream := TFileStream.Create(AppDatFile, fmCreate);
try
MemStream := TMemoryStream.Create;
MemStream.WriteComponent(Layout1);
MemStream.Position := 0;
ObjectBinaryToText(MemStream, FileStream);
finally
MemStream.Free;
FileStream.Free;
end;
end;
procedure TForm1.ButtonClearClick(Sender: TObject);
var
i: Integer;
begin
for i := pred(Layout1.ChildrenCount) downto 0 do
Layout1.Children[i].Free;
end;
procedure TForm1.ButtonLoadClick(Sender: TObject);
var
FileStream : TFileStream;
MemStream : TMemoryStream;
begin
if FileExists(AppDatFile) then
begin
FileStream := TFileStream.Create(AppDatFile, fmOpenRead);
try
MemStream := TMemoryStream.Create;
ObjectTextToBinary(FileStream, MemStream);
MemStream.Position := 0;
MemStream.ReadComponent(Layout1);
Layout1.Align:= TAlignLayout.Client;
finally
MemStream.Free;
FileStream.Free;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
AppPath:= TPath.GetLibraryPath;
AppDatFile:= TPath.Combine(AppPath, 'SaveLoadLayout.dat');
end;
end
FMX File
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 480
ClientWidth = 640
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
DesignerMasterStyle = 0
object RecTop: TRectangle
Align = Top
Size.Width = 640.000000000000000000
Size.Height = 41.000000000000000000
Size.PlatformDefault = False
end
object ButtonSave: TButton
Position.X = 8.000000000000000000
Position.Y = 8.000000000000000000
TabOrder = 3
Text = 'Save'
OnClick = ButtonSaveClick
end
object ButtonClear: TButton
Position.X = 96.000000000000000000
Position.Y = 8.000000000000000000
TabOrder = 2
Text = 'Clear'
OnClick = ButtonClearClick
end
object ButtonLoad: TButton
Position.X = 184.000000000000000000
Position.Y = 8.000000000000000000
TabOrder = 1
Text = 'Load'
OnClick = ButtonLoadClick
end
object Layout1: TLayout
Align = Client
Size.Width = 640.000000000000000000
Size.Height = 439.000000000000000000
Size.PlatformDefault = False
TabOrder = 4
object GridPanelLayout1: TGridPanelLayout
Align = Client
Size.Width = 640.000000000000000000
Size.Height = 439.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
ColumnCollection = <
item
Value = 50.000000000000000000
end
item
Value = 50.000000000000000000
end>
ControlCollection = <
item
Column = 0
Control = Text1
Row = 0
end
item
Column = 1
Control = Text2
Row = 0
end
item
Column = 0
Control = Text3
Row = 1
end
item
Column = 1
Control = Text4
Row = 1
end>
RowCollection = <
item
Value = 50.000000000000000000
end
item
Value = 50.000000000000000000
end>
object Text1: TText
Align = Client
Size.Width = 320.000000000000000000
Size.Height = 219.500000000000000000
Size.PlatformDefault = False
Text = 'Text1'
end
object Text2: TText
Align = Client
Size.Width = 320.000000000000000000
Size.Height = 219.500000000000000000
Size.PlatformDefault = False
Text = 'Text2'
end
object Text3: TText
Align = Client
Size.Width = 320.000000000000000000
Size.Height = 219.500000000000000000
Size.PlatformDefault = False
Text = 'Text3'
end
object Text4: TText
Align = Client
Size.Width = 320.000000000000000000
Size.Height = 219.500000000000000000
Size.PlatformDefault = False
Text = 'Text4'
end
end
end
end
As I said in my comment, the problem is that WriteComponent wrongly write items with the format:
Control = Form1.Text1
This is not correct, it should be
Control = Text1
The behavior is maybe caused by the fact that serializing a component using other component, their owner is saved along.
The workaround is to correct what WriteComponent write. A simple implementation using a simple ReplaceString is like this:
procedure TForm1.ButtonSaveClick(Sender: TObject);
var
StringStream : TStringStream;
MemStream : TMemoryStream;
Buf : String;
begin
MemStream := nil;
StringStream := TStringStream.Create;
try
MemStream := TMemoryStream.Create;
MemStream.WriteComponent(Layout1);
MemStream.Position := 0;
ObjectBinaryToText(MemStream, StringStream);
Buf := StringReplace(StringStream.DataString,
' Control = ' + Self.Name + '.',
' Control = ', [rfReplaceAll]);
TFile.WriteAllText(AppDatFile, Buf);
finally
MemStream.Free;
StringStream.Free;
end;
end;
Be aware that this workaround implementation works for your example but could be confused because the search and replace do not use a real parser and could replace something else having the same form (A string property for example).

Delphi FMX TListview - DynamicAppearance mode - Access Violation problem

Setup TListview, ItemAppearance = DynamicAppearance
in the OnClickItemEX, let's say there's 2 Textobjects. click on both TextObjects - OK. Click on the space between 2 of them - Access Violation.
if click anywhere not covered by an item will result in an Access Violation for the simplest setup.
If I use OnButtonClick only without using OnClickItemEX, no such AV.
How can I resolve this? see below for a Minimal Working Example. (I'm not sure if it's correct to attach it this way as I don't see an Attachment option to upload a zip file of this mini project).
unit bug_main;
interface
type
TForm1 = class(TForm)
ListView1: TListView;
Button1: TButton;
FDMemTable1: TFDMemTable;
BindSourceDB1: TBindSourceDB;
FDMemTable1CustomerID: TIntegerField;
FDMemTable1CustomerName: TStringField;
BindSourceDB2: TBindSourceDB;
BindingsList1: TBindingsList;
procedure Button1Click(Sender: TObject);
procedure ListView1ItemClickEx(const Sender: TObject; ItemIndex: Integer;
const LocalClickPos: TPointF; const ItemObject: TListItemDrawable);
private
FLinkFillControlToField : TLinkFillControlToField;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
procedure TForm1.Button1Click(Sender: TObject);
begin
with FDMemTable1 do
begin
Open;
Append;
FieldByName('CustomerID').AsInteger := 1;
FieldByName('CustomerName').AsString := 'ABC';
Post;
Append;
FieldByName('CustomerID').AsInteger := 2;
FieldByName('CustomerName').AsString := 'XYZ';
Post;
end;
if not Assigned(FLinkFillControlToField) then
begin
FLinkFillControlToField := TLinkFillControlToField.Create(BindingsList1);
FLinkFillControlToField.Control := listview1;
with FLinkFillControlToField do
begin
Category := 'Quick Bindings';
Track := False;
Direction := linkDataToControl;
AutoActivate := False;
AutoFill := True;
BindSourceDB1.DataSource.Enabled := True;
FillDataSource := BindSourceDB1;
end;
end;
with FLinkFillControlToField do
begin
with FillExpressions.AddExpression do
begin
SourceMemberName := 'CustomerID';
ControlMemberName := 'Text1';
end;
with FillExpressions.AddExpression do
begin
SourceMemberName := 'CustomerName';
ControlMemberName := 'Text2';
end;
end;
FLinkFillControlToField.Active := True;
end;
procedure TForm1.ListView1ItemClickEx(const Sender: TObject; ItemIndex: Integer;
const LocalClickPos: TPointF; const ItemObject: TListItemDrawable);
begin
if itemobject.Name = 'Text1' then
begin
showmessage('clicked on Text1');
end else if itemobject.Name = 'Text2' then
begin
showmessage('clicked on Text2');
end;
end;
end.
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 404
ClientWidth = 763
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
DesignerMasterStyle = 0
object ListView1: TListView
ItemAppearanceClassName = 'TDynamicAppearance'
ItemEditAppearanceClassName = 'TDynamicAppearance'
HeaderAppearanceClassName = 'TListHeaderObjects'
FooterAppearanceClassName = 'TListHeaderObjects'
Position.X = 16.000000000000000000
Position.Y = 24.000000000000000000
Size.Width = 561.000000000000000000
Size.Height = 353.000000000000000000
Size.PlatformDefault = False
ItemAppearanceObjects.ItemObjects.ObjectsCollection = <
item
AppearanceObjectName = 'Text1'
AppearanceClassName = 'TTextObjectAppearance'
Appearance.Width = 223.000000000000000000
Appearance.Height = 44.000000000000000000
end
item
AppearanceObjectName = 'Text2'
AppearanceClassName = 'TTextObjectAppearance'
Appearance.Width = 208.000000000000000000
Appearance.Height = 44.000000000000000000
Appearance.PlaceOffset.X = 326.000000000000000000
end>
ItemAppearanceObjects.ItemEditObjects.ObjectsCollection = <
item
AppearanceObjectName = 'Text1'
AppearanceClassName = 'TTextObjectAppearance'
end>
OnItemClickEx = ListView1ItemClickEx
end
object Button1: TButton
Position.X = 592.000000000000000000
Position.Y = 24.000000000000000000
Size.Width = 161.000000000000000000
Size.Height = 57.000000000000000000
Size.PlatformDefault = False
Text = 'Button1'
OnClick = Button1Click
end
object FDMemTable1: TFDMemTable
FetchOptions.AssignedValues = [evMode]
FetchOptions.Mode = fmAll
ResourceOptions.AssignedValues = [rvSilentMode]
ResourceOptions.SilentMode = True
UpdateOptions.AssignedValues = [uvCheckRequired, uvAutoCommitUpdates]
UpdateOptions.CheckRequired = False
UpdateOptions.AutoCommitUpdates = True
Left = 576
Top = 128
object FDMemTable1CustomerID: TIntegerField
FieldName = 'CustomerID'
end
object FDMemTable1CustomerName: TStringField
FieldName = 'CustomerName'
Size = 30
end
end
object BindSourceDB1: TBindSourceDB
DataSet = FDMemTable1
ScopeMappings = <>
Left = 576
Top = 192
end
object BindSourceDB2: TBindSourceDB
DataSet = FDMemTable1
ScopeMappings = <>
Left = 576
Top = 248
end
object BindingsList1: TBindingsList
Methods = <>
OutputConverters = <>
Left = 20
Top = 5
end
end
If you set a breakpoint on the first line of your ListView1ItemClickEx method and then run the app and click between two items, you'll see that there is no ItemObject because you're not clicking on an item (you're clicking between them). This results in ItemObject being nil, and you then try to read the Text value from that unassigned object, causing the AV.
You can correct this by checking to make sure that ItemObject is assigned a value before you use it.
procedure TForm1.ListView1ItemClickEx(const Sender: TObject; ItemIndex: Integer;
const LocalClickPos: TPointF; const ItemObject: TListItemDrawable);
begin
if ItemObject <> nil then
begin
if itemobject.Name = 'Text1' then
begin
ShowMessage('clicked on Text1');
end else if itemobject.Name = 'Text2' then
begin
ShowMessage('clicked on Text2');
end;
end else
ShowMessage('ItemObject is not assigned');
end;
Learning to use the debugger to step through the code will enable you to figure out this sort of simple issue yourself. There's no better tool to have in your programmers toolbox than a good debugger, and Delphi's debugger is quite good.

Get the Total ItemHeight of all the Items arbitrarily defined heights in the TListView at Runtime (Delphi Rio 10.3 FMX)

How to get the total ItemHeight (variably defined) of the items in the TListView at runtime.
The item height, by the way, is arbitrarily defined at runtime using the event UpdateObjects and I should be able to get it from there but I am not getting the correct height for some reasons. I feel it should be easier if I get those after it is defined.
I've tried this approach but no success. But my code ListView1.Items[i].Height looks not right here.
TotalItemHeight := 0;
for i = 0 to ListView1.Items.Count - 1 do
begin
TotalItemHeight := TotalItemHeight + ListView1.Items[i].Height; //I need help here..
end;
.FMX Procedure:
unit MainForm;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
System.Generics.Collections,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
FMX.Controls.Presentation, FMX.StdCtrls, FMX.ListView.Types,
FMX.ListView.Appearances, FMX.ListView.Adapters.Base, FMX.ListView,
Markov;
type
TVariableHeight = class(TForm)
Button1: TButton;
ListView1: TListView;
ToolBar1: TToolBar;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure ListView1UpdateObjects(const Sender: TObject;
const AItem: TListViewItem);
private
FChain: TChain;
FBitmaps: TDictionary<Integer, TBitmap>;
FText: TArray<string>;
procedure ReadText;
function GetDimensionBitmap(const Width, Height: Single): TBitmap;
public
function GetTextHeight(const D: TListItemText; const Width: Single; const Text: string): Integer;
destructor Destroy; override;
end;
var
VariableHeight: TVariableHeight;
implementation
uses
System.IOUtils, FMX.TextLayout;
{$R *.fmx}
// Create a new item with random text of random length
procedure TVariableHeight.Button1Click(Sender: TObject);
begin
ReadText;
ListView1.Items.Add.Data['txtMain'] := FText[Random(Length(FText))];
// with classic appearances, use Text property
//ListView1.Items.Add.Text := FChain.Generate(Random(100) + 5);
end;
function TVariableHeight.GetDimensionBitmap(const Width, Height: Single): TBitmap;
procedure Arrow(C: TCanvas; P: array of TPointF);
begin
C.DrawLine(P[0], P[1], 1.0);
C.DrawLine(P[0], P[2], 1.0);
C.DrawLine(P[0], P[3], 1.0);
end;
var
EndP1, EndP2: TPointF;
TextBitmap: TBitmap;
IntHeight: Integer;
begin
IntHeight := Trunc(Height);
if FBitmaps = nil then
FBitmaps := TDictionary<Integer, TBitmap>.Create;
if not FBitmaps.TryGetValue(IntHeight, Result) then
begin
Result := TBitmap.Create(Trunc(Width), IntHeight);
FBitmaps.Add(IntHeight, Result);
if Result.Canvas.BeginScene then
begin
Result.Canvas.Clear(TAlphaColorRec.Null);
Result.Canvas.Stroke.Color := TAlphaColorRec.Darkgray;
// Draw the arrows
EndP1 := TPointF.Create(Width/2, 0);
EndP2 := TPointF.Create(Width/2, Height);
Arrow(Result.Canvas,
[EndP1, TPointF.Create(Width/2, Height/2 - Width/2),
EndP1 + TPointF.Create(-2, 5), EndP1 + TPointF.Create(2, 5)]);
Arrow(Result.Canvas,
[EndP2, TPointF.Create(Width/2, Height/2 + Width/2),
EndP2 + TPointF.Create(-2, -5), EndP2 + TPointF.Create(2, -5)]);
// Draw the dimension text
TextBitmap := TBitmap.Create(Trunc(Width), Trunc(Width));
try
if TextBitmap.Canvas.BeginScene then
with TextBitmap.Canvas do
begin
Clear(TAlphaColorRec.Null);
Fill.Color := TAlphaColorRec.Darkgray;
FillText(TextBitmap.BoundsF, ''.Format('%d', [IntHeight]), False, 1,
[], TTextAlign.Center, TTextAlign.Center);
EndScene;
end;
TextBitmap.Rotate(90);
Result.Canvas.DrawBitmap(TextBitmap, TextBitmap.BoundsF,
TextBitmap.BoundsF.CenterAt(Result.BoundsF), 1);
finally
TextBitmap.Free;
end;
Result.Canvas.EndScene;
end;
end;
end;
destructor TVariableHeight.Destroy;
var
Key: Integer;
begin
FChain.Free;
if FBitmaps <> nil then
for Key in FBitmaps.Keys do
FBitmaps[Key].Free;
FBitmaps.Free;
inherited;
end;
// Calculate height for text drawable D
function TVariableHeight.GetTextHeight(const D: TListItemText; const Width: single; const Text: string): Integer;
var
Layout: TTextLayout;
begin
// Create a TTextLayout to measure text dimensions
Layout := TTextLayoutManager.DefaultTextLayout.Create;
try
Layout.BeginUpdate;
try
// Initialize layout parameters with those of the drawable
Layout.Font.Assign(D.Font);
Layout.VerticalAlign := D.TextVertAlign;
Layout.HorizontalAlign := D.TextAlign;
Layout.WordWrap := D.WordWrap;
Layout.Trimming := D.Trimming;
Layout.MaxSize := TPointF.Create(Width, TTextLayout.MaxLayoutSize.Y);
Layout.Text := Text;
finally
Layout.EndUpdate;
end;
// Get layout height
Result := Round(Layout.Height);
// Add one em to the height
Layout.Text := 'm';
Result := Result + Round(Layout.Height);
finally
Layout.Free;
end;
end;
procedure TVariableHeight.ListView1UpdateObjects(const Sender: TObject;
const AItem: TListViewItem);
var
Drawable: TListItemText;
SizeImg: TListItemImage;
Text: string;
AvailableWidth: Single;
begin
SizeImg := TListItemImage(AItem.View.FindDrawable('imgSize'));
AvailableWidth := TListView(Sender).Width - TListView(Sender).ItemSpaces.Left
- TListView(Sender).ItemSpaces.Right - SizeImg.Width;
ShowMessage(TListView(Sender).Height.ToString);
// Find the text drawable which is used to calcualte item size.
// For dynamic appearance, use item name.
// For classic appearances use TListViewItem.TObjectNames.Text
// Drawable := TListItemText(AItem.View.FindDrawable(TListViewItem.TObjectNames.Text));
Drawable := TListItemText(AItem.View.FindDrawable('txtMain'));
Text := Drawable.Text;
// Randomize the font when updating for the first time
if Drawable.TagFloat = 0 then
begin
Drawable.Font.Size := 1; // Ensure that default font sizes do not play against us
Drawable.Font.Size := 10 + Random(4) * 4;
Drawable.TagFloat := Drawable.Font.Size;
if Text.Length < 100 then
Drawable.Font.Style := [TFontStyle.fsBold];
end;
// Calculate item height based on text in the drawable
AItem.Height := GetTextHeight(Drawable, AvailableWidth, Text);
Drawable.Height := AItem.Height;
Drawable.Width := AvailableWidth;
SizeImg.OwnsBitmap := False;
SizeImg.Bitmap := GetDimensionBitmap(SizeImg.Width, AItem.Height);
end;
procedure TVariableHeight.ReadText;
const
Delimiters: array of char = [#10, #13];
var
Reader: TStreamReader;
Stream: TResourceStream;
begin
if Length(FText) = 0 then
begin
Stream := TResourceStream.Create(HInstance, 'Blabla', RT_RCDATA);
Reader := TStreamReader.Create(Stream);
try
FText := Reader.ReadToEnd.Split(Delimiters, TStringSplitOptions.ExcludeEmpty)
finally
Reader.Close;
Reader.Free;
Stream.Free;
end;
end;
end;
end.
.FMX File
object VariableHeight: TVariableHeight
Left = 0
Top = 0
Caption = 'VariableHeight'
ClientHeight = 480
ClientWidth = 510
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
DesignerMasterStyle = 0
object ListView1: TListView
ItemAppearanceClassName = 'TDynamicAppearance'
ItemEditAppearanceClassName = 'TDynamicAppearance'
HeaderAppearanceClassName = 'TListHeaderObjects'
FooterAppearanceClassName = 'TListHeaderObjects'
OnUpdateObjects = ListView1UpdateObjects
Align = Client
Size.Width = 510.000000000000000000
Size.Height = 436.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
ItemAppearanceObjects.ItemObjects.ObjectsCollection = <
item
AppearanceObjectName = 'txtMain'
AppearanceClassName = 'TTextObjectAppearance'
Appearance.TextAlign = Leading
Appearance.WordWrap = True
Appearance.Height = 44.000000000000000000
Appearance.VertAlign = Center
end
item
AppearanceObjectName = 'imgSize'
AppearanceClassName = 'TImageObjectAppearance'
Appearance.ScalingMode = Original
Appearance.Width = 30.000000000000000000
Appearance.Align = Trailing
end>
ItemAppearanceObjects.ItemEditObjects.ObjectsCollection = <
item
AppearanceObjectName = 'Text1'
AppearanceClassName = 'TTextObjectAppearance'
end>
end
object ToolBar1: TToolBar
Padding.Top = 4.000000000000000000
Padding.Bottom = 4.000000000000000000
Size.Width = 510.000000000000000000
Size.Height = 44.000000000000000000
Size.PlatformDefault = False
TabOrder = 1
object Label1: TLabel
Align = Contents
Size.Width = 510.000000000000000000
Size.Height = 44.000000000000000000
Size.PlatformDefault = False
StyleLookup = 'toollabel'
TextSettings.HorzAlign = Center
Text = 'Variable Row Height Demo'
end
object Button1: TButton
Align = Right
Margins.Right = 5.000000000000000000
Position.X = 448.000000000000000000
Position.Y = 4.000000000000000000
Size.Width = 57.000000000000000000
Size.Height = 36.000000000000000000
Size.PlatformDefault = False
StyleLookup = 'listitembutton'
TabOrder = 1
Text = 'Fill List'
OnClick = Button1Click
end
end
end

Resources