Change the Number Format in TListView TObjectAppearance - delphi

I have TListView livebinded with the TFDQuery. One of the data is mapped to Item Detail which is basically a number. I would like the number to be formatted to ##,##0.00. Looking at the Object Inspector there is no property that I can change the data format.
Is there a way that I can change the ItemAppearance of a number in the TListView?
Below the screenshot showing the Object Inspector, Toogle Design, and Debug views:
FMX Procedures:
unit Unit9;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
FMX.ListView.Types, FMX.ListView.Appearances, FMX.ListView.Adapters.Base,
FireDAC.Stan.Intf, FireDAC.Stan.Option, FireDAC.Stan.Error, FireDAC.UI.Intf,
FireDAC.Phys.Intf, FireDAC.Stan.Def, FireDAC.Stan.Pool, FireDAC.Stan.Async,
FireDAC.Phys, FireDAC.Phys.SQLite, FireDAC.Phys.SQLiteDef,
FireDAC.Stan.ExprFuncs, FireDAC.FMXUI.Wait, FireDAC.Stan.Param, FireDAC.DatS,
FireDAC.DApt.Intf, FireDAC.DApt, Data.Bind.EngExt, Fmx.Bind.DBEngExt,
System.Rtti, System.Bindings.Outputs, Fmx.Bind.Editors, Data.Bind.Components,
Data.Bind.DBScope, Data.DB, FireDAC.Comp.DataSet, FireDAC.Comp.Client,
FMX.ListView, FMX.Controls.Presentation, FMX.StdCtrls, FMX.Edit;
type
TForm9 = class(TForm)
lbl1: TLabel;
lsv1: TListView;
con1: TFDConnection;
qryLists: TFDQuery;
bdr1: TBindSourceDB;
bdl1: TBindingsList;
tcf1: TLinkFillControlToField;
lpfText: TLinkPropertyToField;
qryInsert: TFDQuery;
btn1: TButton;
lnkcntrltfld1: TLinkControlToField;
procedure btn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form9: TForm9;
implementation
{$R *.fmx}
procedure TForm9.btn1Click(Sender: TObject);
begin
qryInsert.ParamByName('id').AsInteger := 1;
qryInsert.ParamByName('cur_datetime').AsDateTime := now;
qryInsert.ParamByName('name').AsString := 'sample';
qryInsert.ParamByName('size_cont').AsString := 'size_cont';
qryInsert.ParamByName('qty').AsFloat := 10;
qryInsert.ParamByName('est_price').AsFloat := 1234.5;
qryInsert.ParamByName('qty_price').AsString := '10 x 1234.5';
qryInsert.ParamByName('estimate').AsFloat := 10 * 1234.5;
qryInsert.ExecSQL;
qryLists.Close;
qryLists.Open();
end;
end.
FMX File:
object Form9: TForm9
Left = 0
Top = 0
Caption = 'Form9'
ClientHeight = 480
ClientWidth = 308
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
DesignerMasterStyle = 0
object lbl1: TLabel
Align = Top
StyledSettings = [Family, Style, FontColor]
Size.Width = 308.000000000000000000
Size.Height = 33.000000000000000000
Size.PlatformDefault = False
TextSettings.Font.Size = 14.000000000000000000
TextSettings.HorzAlign = Center
Text = '1869'
TabOrder = 0
end
object lsv1: TListView
ItemAppearanceClassName = 'TImageListItemBottomDetailAppearance'
ItemEditAppearanceClassName = 'TImageListItemBottomDetailShowCheckAppearance'
HeaderAppearanceClassName = 'TListHeaderObjects'
FooterAppearanceClassName = 'TListHeaderObjects'
Align = Client
Size.Width = 308.000000000000000000
Size.Height = 407.000000000000000000
Size.PlatformDefault = False
TabOrder = 1
ItemAppearanceObjects.ItemObjects.Text.Width = 201.000000000000000000
ItemAppearanceObjects.ItemObjects.Text.Height = 20.000000000000000000
ItemAppearanceObjects.ItemObjects.Text.PlaceOffset.Y = 1.000000000000000000
ItemAppearanceObjects.ItemObjects.Detail.Width = 201.000000000000000000
ItemAppearanceObjects.ItemObjects.Detail.Height = 20.000000000000000000
ItemAppearanceObjects.ItemObjects.Detail.PlaceOffset.Y = 24.000000000000000000
end
object btn1: TButton
Align = Bottom
Position.Y = 440.000000000000000000
Size.Width = 308.000000000000000000
Size.Height = 40.000000000000000000
Size.PlatformDefault = False
TabOrder = 7
Text = 'btn1'
OnClick = btn1Click
end
object con1: TFDConnection
Params.Strings = (
'Database=D:\My Project Files\5. my_projects_aws-rest\project_x_v' +
'0\application\client\database\smartcart.s3db'
'LockingMode=Normal'
'DriverID=SQLite')
Connected = True
LoginPrompt = False
Left = 72
Top = 24
end
object qryLists: TFDQuery
Active = True
Connection = con1
SQL.Strings = (
'SELECT id, date_created, name, size_cont, qty_price, estimate'
'FROM lists ORDER BY date_created DESC')
Left = 112
Top = 24
end
object bdr1: TBindSourceDB
DataSet = qryLists
ScopeMappings = <>
Left = 152
Top = 24
end
object bdl1: TBindingsList
Methods = <>
OutputConverters = <>
Left = 20
Top = 5
object tcf1: TLinkFillControlToField
Category = 'Quick Bindings'
Control = lsv1
Track = True
FillDataSource = bdr1
AutoFill = True
FillExpressions = <
item
SourceMemberName = 'estimate'
ControlMemberName = 'Detail'
end>
FillHeaderExpressions = <>
FillBreakGroups = <>
end
object lpfText: TLinkPropertyToField
Category = 'Quick Bindings'
DataSource = bdr1
FieldName = 'estimate'
Component = lbl1
ComponentProperty = 'Text'
end
object lnkcntrltfld1: TLinkControlToField
Category = 'Quick Bindings'
DataSource = bdr1
FieldName = 'estimate'
Track = False
end
end
object qryInsert: TFDQuery
Connection = con1
SQL.Strings = (
'INSERT INTO lists (id, date_created, name, size_cont, '
' qty, est_price, qty_price, estimate) '
'VALUES (:id, :cur_datetime, :name, :size_cont, '
' :qty, :est_price, :qty_price, :estimate);')
Left = 192
Top = 24
ParamData = <
item
Name = 'ID'
DataType = ftInteger
ParamType = ptInput
Value = Null
end
item
Name = 'CUR_DATETIME'
DataType = ftDateTime
ParamType = ptInput
Value = Null
end
item
Name = 'NAME'
DataType = ftString
ParamType = ptInput
Value = Null
end
item
Name = 'SIZE_CONT'
DataType = ftString
ParamType = ptInput
Value = Null
end
item
Name = 'QTY'
DataType = ftFloat
ParamType = ptInput
Value = Null
end
item
Name = 'EST_PRICE'
DataType = ftFloat
ParamType = ptInput
Value = Null
end
item
Name = 'QTY_PRICE'
DataType = ftString
ParamType = ptInput
Value = Null
end
item
Name = 'ESTIMATE'
DataType = ftFloat
ParamType = ptInput
Value = Null
end>
end
end

There are 2 approaches applicable to this case:
At TListView level TLinkControlToField1 -> CustomFormat : "$ "+UpperCase(%s). This is the most applicable approach as the number stays in its number format and can be included in the calculation. You might wonder what the Uppercase is doing here? It is only to show (%s) the data as string and has no effect.
Use the Display Format of the TDataset field with this format $ #,##0.00. In this approach, the $ will create an error when you start to include this number in your calculation.
You should check this link to a more detailed explanation https://stackoverflow.com/a/18819719/13810710.

Related

Inserting a row to Dataset has unsual delay at Delphi Alexandria 11.1 when load a big lookup Fields

Recently i have completed the migration of my company's project, from Delphi XE7 to Alexandria 11.1. After a couple of releases, some customers with bigger databases complained for delays at opening my most used form. I have started to research the problem and i found out, that the delay occurs at the insertion of a row to the master TClientDataset of the form. The TClientDataset has around 50 TField with 5 of them, been lookup an the another ADOQuery with around 100000 rows.
In order to isolate the problem, i have created a project with an ADOQuery with 100000 rows as with 5 fields, and another ADOQuery with lookup fields to the first. I insert a row and copy a value to key Field and post the row. I notice that it need around 40ms to complete for Alexandria and 2ms for XE7.
Those times scale up if i create more lookup fields, or assign values to the rest of the fields. In my project in some scenarios, load time of 3-4 seconds in XE7 rise up to 12-15 in Alexandria. This is more clear in release
I have tried to debug VCL code and compare the files of Ado and dsnap folders of each version, but i haven't figure out what has change.
I have google about it, and i haven't find any similar report. I wonder if this is a bug in the newest Delphi, or am i missing something else, maybe a new option. Does anyone have a similar experience? I will appreciate any info about the subject.
I will leave the sql script of the Database and the Delphi Code if anyone want to reproduce it.
The SQL SCRIPT:
CREATE TABLE [dbo].[Persons](
[ID] [int] NOT NULL,
[ModifiedDate] [datetime] NULL,
[FirstName] [varchar](50) NULL,
[LastName] [varchar](50) NULL,
[EMail] [varchar](30) NULL,
[PhoneNumber] [varchar](15) NULL,
PRIMARY KEY CLUSTERED
(
[ID] ASC
) ON [PRIMARY]
) ON [PRIMARY]
CREATE TABLE [dbo].[Books](
[BookID] [int] NOT NULL,
[Title] [nchar](50) NOT NULL,
[PersonID] [int] NOT NULL,
CONSTRAINT [PK_Books] PRIMARY KEY CLUSTERED
(
[BookID] ASC
) ON [PRIMARY]
) ON [PRIMARY]
DECLARE #RowCount int = 100000,
#Index int = 1
WHILE (#Index <= #RowCount)
BEGIN
INSERT INTO Persons (ID, ModifiedDate, FirstName, LastName, EMail, PhoneNumber)
VALUES (#Index, getdate(), 'FirstName' + CAST(#Index AS varchar(10)), 'LastName' + CAST(#Index AS varchar(10)), 'EMail' + CAST(#Index AS varchar(10)), CAST(#Index AS varchar(10)))
SET #Index += 1
END
The DFM:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 177
ClientWidth = 179
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = 'Segoe UI'
Font.Style = []
OnCreate = FormCreate
TextHeight = 15
object BitBtn1: TBitBtn
Left = 56
Top = 144
Width = 75
Height = 25
Caption = 'Load'
TabOrder = 0
OnClick = BitBtn1Click
end
object luPersons: TADOQuery
Connection = ADOConnection1
CursorType = ctStatic
Parameters = <>
SQL.Strings = (
'SELECT *'
'FROM PERSONS')
Left = 32
Top = 72
object luPersonsID: TIntegerField
FieldName = 'ID'
ProviderFlags = [pfInUpdate, pfInWhere, pfInKey]
end
object luPersonsModifiedDate: TDateTimeField
FieldName = 'ModifiedDate'
end
object luPersonsFirstName: TStringField
FieldName = 'FirstName'
Size = 50
end
object luPersonsLastName: TStringField
FieldName = 'LastName'
Size = 50
end
object luPersonsEMail: TStringField
FieldName = 'EMail'
Size = 30
end
object luPersonsPhoneNumber: TStringField
FieldName = 'PhoneNumber'
Size = 15
end
end
object ADOConnection1: TADOConnection
ConnectionString =
'Provider=SQLNCLI11.1;Persist Security Info=False;User ID=sa;Pass' +
'word=password;Initial Catalog=testDB;Data Source=DATABASE;' +
'Use Procedure for Prepare=1;Auto Translate=True;Pack' +
'et Size=4096;Workstation ID=Workstation;Initial File Name=""' +
';Use Encryption for Data=False;Tag with column collation when po' +
'ssible=False;MARS Connection=False;DataTypeCompatibility=0;Trust' +
' Server Certificate=False;Server SPN="";Application Intent=READW' +
'RITE'
Provider = 'SQLNCLI11.1'
Left = 80
Top = 16
end
object qBooks: TADOQuery
Connection = ADOConnection1
CursorType = ctStatic
Parameters = <>
SQL.Strings = (
'SELECT *'
'FROM BOOKS')
Left = 128
Top = 72
object qBooksBookID: TIntegerField
FieldName = 'BookID'
ProviderFlags = [pfInUpdate, pfInWhere, pfInKey]
end
object qBooksTitle: TWideStringField
FieldName = 'Title'
FixedChar = True
Size = 50
end
object qBooksPersonID: TIntegerField
FieldName = 'PersonID'
end
object qBooksModifiedDate: TDateTimeField
FieldKind = fkLookup
FieldName = 'ModifiedDate'
LookupDataSet = luPersons
LookupKeyFields = 'ID'
LookupResultField = 'ModifiedDate'
KeyFields = 'PersonID'
Lookup = True
end
object qBooksFirstName: TStringField
FieldKind = fkLookup
FieldName = 'FirstName'
LookupDataSet = luPersons
LookupKeyFields = 'ID'
LookupResultField = 'FirstName'
KeyFields = 'PersonID'
Size = 50
Lookup = True
end
object qBooksLastName: TStringField
FieldKind = fkLookup
FieldName = 'LastName'
LookupDataSet = luPersons
LookupKeyFields = 'ID'
LookupResultField = 'LastName'
KeyFields = 'PersonID'
Size = 50
Lookup = True
end
object qBooksEMail: TStringField
FieldKind = fkLookup
FieldName = 'EMail'
LookupDataSet = luPersons
LookupKeyFields = 'ID'
LookupResultField = 'EMail'
KeyFields = 'PersonID'
Size = 30
Lookup = True
end
object qBooksPhoneNumber: TStringField
FieldKind = fkLookup
FieldName = 'PhoneNumber'
LookupDataSet = luPersons
LookupKeyFields = 'ID'
LookupResultField = 'PhoneNumber'
KeyFields = 'PersonID'
Size = 15
Lookup = True
end
end
end
And the PAS source code:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Data.DB, Data.Win.ADODB, Vcl.StdCtrls, Vcl.Buttons;
type
TForm1 = class(TForm)
luPersons: TADOQuery;
ADOConnection1: TADOConnection;
luPersonsID: TIntegerField;
luPersonsModifiedDate: TDateTimeField;
luPersonsFirstName: TStringField;
luPersonsLastName: TStringField;
luPersonsEMail: TStringField;
luPersonsPhoneNumber: TStringField;
qBooks: TADOQuery;
qBooksBookID: TIntegerField;
qBooksTitle: TWideStringField;
qBooksPersonID: TIntegerField;
qBooksModifiedDate: TDateTimeField;
qBooksFirstName: TStringField;
qBooksLastName: TStringField;
qBooksEMail: TStringField;
qBooksPhoneNumber: TStringField;
BitBtn1: TBitBtn;
procedure FormCreate(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses System.DateUtils;
procedure TForm1.BitBtn1Click(Sender: TObject);
var
starttime, endtime: TTime;
begin
starttime := Time;
qBooks.Open;
qBooks.Insert;
qBooksBookID.AsInteger := 1;
qBooksPersonID.AsInteger := 1;
endtime := Time;
ShowMessage(MilliSecondsBetween(endtime, starttime).ToString + ' ' + FormatDateTime('hh:mm:ss.zzz', starttime) +
' ' + FormatDateTime('hh:mm:ss.zzz', endtime));
qBooks.Close;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
luPersons.Open;
end;
end.

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).

How to refresh Livebinding for TListView and TFDMemTable?

I have a TListView livebinded with TFDMemTable. I also have a TButton that adds the item on the TFDMemTable which obviously shown in the TListView after adding the item. The TListView is located in one of the TTabItem of TTabControl.
My problem is, when I changed the tab at runtime and go back to TListView tab to add more item, the previously shown data will become empty after adding more item.
I can confirm that the data in the TFDMemTable are still intact including the newly added ones.
I suspect the livebinding needs to be refreshed in order to get all the data back to TListView.
Does anyone have any idea on how to refresh the livebinding at runtime?
P.S. I hope the above explains my issue clearly. Otherwise, please let me know if you need more details.
UPDATE 1: MINIMUM REPRODUCIBLE EXAMPLE
Here's the least that I can do for the MRE, not the exact scenario of my case but should be the same issue. You will come to notice after adding list on the TabItem2 and you go back to TabItem1 to add more item on the lists, the existing detail on the list will be gone.
FMX Procedure
unit TabbedFormwithNavigation;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.TabControl, FMX.StdCtrls, FMX.Controls.Presentation,
FMX.Gestures, System.Actions, FMX.ActnList, FMX.ListView.Types,
FMX.ListView.Appearances, FMX.ListView.Adapters.Base, REST.Types,
FireDAC.Stan.Intf, FireDAC.Stan.Option, FireDAC.Stan.Param,
FireDAC.Stan.Error, FireDAC.DatS, FireDAC.Phys.Intf, FireDAC.DApt.Intf,
System.Rtti, System.Bindings.Outputs, Fmx.Bind.Editors, Data.Bind.EngExt,
Fmx.Bind.DBEngExt, Data.Bind.Components, Data.Bind.DBScope, Data.DB,
FireDAC.Comp.DataSet, FireDAC.Comp.Client, REST.Response.Adapter, REST.Client,
Data.Bind.ObjectScope, FMX.ListView;
type
TTabbedwithNavigationForm = class(TForm)
TabControl1: TTabControl;
TabItem1: TTabItem;
TabItem2: TTabItem;
GestureManager1: TGestureManager;
ActionList1: TActionList;
NextTabAction1: TNextTabAction;
PreviousTabAction1: TPreviousTabAction;
lsv1: TListView;
rsc1: TRESTClient;
rsq1: TRESTRequest;
rsp1: TRESTResponse;
rsd1: TRESTResponseDataSetAdapter;
mtb1: TFDMemTable;
bdr1: TBindSourceDB;
bdl1: TBindingsList;
lsv2: TListView;
rsc2: TRESTClient;
rsq2: TRESTRequest;
rsp2: TRESTResponse;
rsd2: TRESTResponseDataSetAdapter;
mtb2: TFDMemTable;
bdr2: TBindSourceDB;
lcf1: TLinkListControlToField;
btn1: TButton;
lsv3: TListView;
mtb3: TFDMemTable;
strngfldmtb3brandname: TStringField;
strngfldmtb3brand: TStringField;
bdr3: TBindSourceDB;
lcf3: TLinkListControlToField;
lcf2: TLinkListControlToField;
pnl1: TPanel;
lbl1: TLabel;
pnl2: TPanel;
lbl2: TLabel;
pnl3: TPanel;
lbl3: TLabel;
procedure GestureDone(Sender: TObject; const EventInfo: TGestureEventInfo; var Handled: Boolean);
procedure FormCreate(Sender: TObject);
procedure FormKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
procedure lsv1ItemClick(const Sender: TObject; const AItem: TListViewItem);
procedure btn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
TabbedwithNavigationForm: TTabbedwithNavigationForm;
implementation
{$R *.fmx}
procedure TTabbedwithNavigationForm.btn1Click(Sender: TObject);
var
brandname : string;
begin
brandname := mtb2.Lookup('name', lsv2.Items[lsv2.ItemIndex].Text, 'name');
// ShowMessage(lsv2.Items[lsv2.ItemIndex].Text);
if mtb3.Locate('brandname', brandname, []) = False then
begin
mtb3.DisableControls;
mtb3.Append;
mtb3.FieldByName('brandname').AsString := brandname;
mtb3.EnableControls;
mtb3.Post;
end;
end;
procedure TTabbedwithNavigationForm.FormCreate(Sender: TObject);
begin
{ This defines the default active tab at runtime }
TabControl1.ActiveTab := TabItem1;
rsq1.Execute;
end;
procedure TTabbedwithNavigationForm.FormKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
begin
if Key = vkHardwareBack then
begin
if (TabControl1.ActiveTab = TabItem1) then
begin
Key := 0;
end;
end;
end;
procedure TTabbedwithNavigationForm.GestureDone(Sender: TObject; const EventInfo: TGestureEventInfo; var Handled: Boolean);
begin
case EventInfo.GestureID of
sgiLeft:
begin
if TabControl1.ActiveTab <> TabControl1.Tabs[TabControl1.TabCount - 1] then
TabControl1.ActiveTab := TabControl1.Tabs[TabControl1.TabIndex + 1];
Handled := True;
end;
sgiRight:
begin
if TabControl1.ActiveTab <> TabControl1.Tabs[0] then
TabControl1.ActiveTab := TabControl1.Tabs[TabControl1.TabIndex - 1];
Handled := True;
end;
end;
end;
procedure TTabbedwithNavigationForm.lsv1ItemClick(const Sender: TObject;
const AItem: TListViewItem);
var
SearchItem : String;
begin
//place the equivalent api for the meta click
SearchItem := lsv1.Items[lsv1.ItemIndex].Text;
rsc2.BaseURL := 'https://nm5c906csg.execute-api.ap-southeast-1.amazonaws.com/v0/dbqueries?search-item=' + SearchItem;
//execute api request for the searches
rsq2.Execute;
TabControl1.TabIndex := 1;
end;
end.
FMX File
object TabbedwithNavigationForm: TTabbedwithNavigationForm
Left = 0
Top = 0
Caption = 'Form56'
ClientHeight = 596
ClientWidth = 405
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
OnKeyUp = FormKeyUp
DesignerMasterStyle = 0
object TabControl1: TTabControl
Touch.GestureManager = GestureManager1
OnGesture = GestureDone
Align = Client
FullSize = True
Size.Width = 405.000000000000000000
Size.Height = 596.000000000000000000
Size.PlatformDefault = False
TabHeight = 49.000000000000000000
TabIndex = 1
TabOrder = 0
TabPosition = PlatformDefault
Sizes = (
405s
547s
405s
547s)
object TabItem1: TTabItem
CustomIcon = <
item
end>
IsSelected = False
Size.Width = 201.000000000000000000
Size.Height = 49.000000000000000000
Size.PlatformDefault = False
StyleLookup = 'tabitemfavorites'
TabOrder = 0
Text = 'TabItem1'
ExplicitSize.cx = 101.000000000000000000
ExplicitSize.cy = 49.000000000000000000
object lsv1: TListView
ItemAppearanceClassName = 'TListItemAppearance'
ItemEditAppearanceClassName = 'TListItemShowCheckAppearance'
HeaderAppearanceClassName = 'TListHeaderObjects'
FooterAppearanceClassName = 'TListHeaderObjects'
ItemIndex = 0
Align = Client
Size.Width = 405.000000000000000000
Size.Height = 487.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
OnItemClick = lsv1ItemClick
end
object pnl1: TPanel
Align = Top
Size.Width = 405.000000000000000000
Size.Height = 60.000000000000000000
Size.PlatformDefault = False
TabOrder = 1
object lbl1: TLabel
Align = Client
StyledSettings = [Family, FontColor]
Margins.Left = 60.000000000000000000
Margins.Right = 60.000000000000000000
Size.Width = 285.000000000000000000
Size.Height = 60.000000000000000000
Size.PlatformDefault = False
TextSettings.Font.Size = 14.000000000000000000
TextSettings.Font.StyleExt = {00070000000000000004000000}
TextSettings.HorzAlign = Center
Text = 'Please select an item here to filter out items for TabItem2.'
TabOrder = 0
end
end
end
object TabItem2: TTabItem
CustomIcon = <
item
end>
IsSelected = True
Size.Width = 202.000000000000000000
Size.Height = 49.000000000000000000
Size.PlatformDefault = False
StyleLookup = 'tabitemcontacts'
TabOrder = 0
Text = 'TabItem2'
ExplicitSize.cx = 102.000000000000000000
ExplicitSize.cy = 49.000000000000000000
object lsv2: TListView
ItemAppearanceClassName = 'TImageListItemBottomDetailAppearance'
ItemEditAppearanceClassName = 'TImageListItemBottomDetailShowCheckAppearance'
HeaderAppearanceClassName = 'TListHeaderObjects'
FooterAppearanceClassName = 'TListHeaderObjects'
ItemIndex = 0
Align = Top
Position.Y = 60.000000000000000000
Size.Width = 405.000000000000000000
Size.Height = 221.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
end
object btn1: TButton
Align = Top
StyledSettings = [Family, FontColor]
Position.Y = 281.000000000000000000
Size.Width = 405.000000000000000000
Size.Height = 40.000000000000000000
Size.PlatformDefault = False
TabOrder = 1
Text = 'SELECT'
TextSettings.Font.Size = 14.000000000000000000
TextSettings.Font.StyleExt = {00070000000000000004000000}
OnClick = btn1Click
end
object lsv3: TListView
ItemAppearanceClassName = 'TImageListItemBottomDetailAppearance'
ItemEditAppearanceClassName = 'TImageListItemBottomDetailShowCheckAppearance'
HeaderAppearanceClassName = 'TListHeaderObjects'
FooterAppearanceClassName = 'TListHeaderObjects'
Align = Client
Size.Width = 405.000000000000000000
Size.Height = 166.000000000000000000
Size.PlatformDefault = False
TabOrder = 2
end
object pnl2: TPanel
Align = Top
Size.Width = 405.000000000000000000
Size.Height = 60.000000000000000000
Size.PlatformDefault = False
TabOrder = 3
object lbl2: TLabel
Align = Client
StyledSettings = [Family, FontColor]
Margins.Left = 30.000000000000000000
Margins.Right = 30.000000000000000000
Size.Width = 345.000000000000000000
Size.Height = 60.000000000000000000
Size.PlatformDefault = False
TextSettings.Font.Size = 14.000000000000000000
TextSettings.Font.StyleExt = {00070000000000000004000000}
TextSettings.HorzAlign = Center
Text =
'Select an item below then click the "SELECT" button to list down' +
' the items selected.'
TabOrder = 0
end
end
object pnl3: TPanel
Align = Bottom
Position.Y = 487.000000000000000000
Size.Width = 405.000000000000000000
Size.Height = 60.000000000000000000
Size.PlatformDefault = False
TabOrder = 4
object lbl3: TLabel
Align = Client
StyledSettings = [Family]
Size.Width = 405.000000000000000000
Size.Height = 60.000000000000000000
Size.PlatformDefault = False
TextSettings.Font.StyleExt = {00070000000000000004000000}
TextSettings.FontColor = claRed
TextSettings.HorzAlign = Center
Text =
'The error comes when you go back to TabItem1 and select another ' +
'item, the existing details on the list will be gone.'
TabOrder = 0
end
end
end
end
object GestureManager1: TGestureManager
Sensitivity = 80.000000000000000000
Left = 48
Top = 185
GestureData = <
item
Control = TabControl1
Collection = <
item
GestureID = sgiLeft
end
item
GestureID = sgiRight
end>
end>
end
object ActionList1: TActionList
Left = 48
Top = 120
object NextTabAction1: TNextTabAction
Category = 'Tab'
end
object PreviousTabAction1: TPreviousTabAction
Category = 'Tab'
end
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://bs3winlz02.execute-api.ap-southeast-1.amazonaws.com/v0/d' +
'bqueries'
Params = <>
Left = 136
Top = 120
end
object rsq1: TRESTRequest
Client = rsc1
Params = <>
Response = rsp1
SynchronizedEvents = False
Left = 136
Top = 184
end
object rsp1: TRESTResponse
ContentType = 'application/json'
Left = 136
Top = 248
end
object rsd1: TRESTResponseDataSetAdapter
Active = True
Dataset = mtb1
FieldDefs = <>
Response = rsp1
Left = 136
Top = 312
end
object mtb1: TFDMemTable
Active = True
FieldDefs = <
item
Name = 'meta'
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 = 136
Top = 376
end
object bdr1: TBindSourceDB
DataSet = mtb1
ScopeMappings = <>
Left = 136
Top = 440
end
object bdl1: TBindingsList
Methods = <>
OutputConverters = <>
Left = 20
Top = 5
object lcf1: TLinkListControlToField
Category = 'Quick Bindings'
DataSource = bdr1
FieldName = 'meta'
Control = lsv1
FillExpressions = <>
FillHeaderExpressions = <>
FillBreakGroups = <>
end
object lcf3: TLinkListControlToField
Category = 'Quick Bindings'
DataSource = bdr3
FieldName = 'brandname'
Control = lsv3
FillExpressions = <
item
SourceMemberName = 'brand'
ControlMemberName = 'Detail'
end>
FillHeaderExpressions = <>
FillBreakGroups = <>
end
object lcf2: TLinkListControlToField
Category = 'Quick Bindings'
DataSource = bdr2
FieldName = 'name'
Control = lsv2
FillExpressions = <
item
SourceMemberName = 'brand'
ControlMemberName = 'Detail'
end>
FillHeaderExpressions = <>
FillBreakGroups = <>
end
end
object rsc2: TRESTClient
Accept = 'application/json, text/plain; q=0.9, text/html;q=0.8,'
AcceptCharset = 'utf-8, *;q=0.8'
BaseURL =
'https://nm5c906csg.execute-api.ap-southeast-1.amazonaws.com/v0/d' +
'bqueries?search-item=sage'
Params = <>
Left = 200
Top = 120
end
object rsq2: TRESTRequest
Client = rsc2
Params = <>
Response = rsp2
SynchronizedEvents = False
Left = 200
Top = 184
end
object rsp2: TRESTResponse
ContentType = 'application/json'
Left = 200
Top = 248
end
object rsd2: TRESTResponseDataSetAdapter
Active = True
Dataset = mtb2
FieldDefs = <>
Response = rsp2
Left = 200
Top = 312
end
object mtb2: TFDMemTable
Active = True
FieldDefs = <
item
Name = 'brand'
DataType = ftWideString
Size = 255
end
item
Name = 'name'
DataType = ftWideString
Size = 255
end
item
Name = 'description'
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 = 200
Top = 376
end
object bdr2: TBindSourceDB
DataSet = mtb2
ScopeMappings = <>
Left = 200
Top = 440
end
object mtb3: TFDMemTable
Active = True
FetchOptions.AssignedValues = [evMode]
FetchOptions.Mode = fmAll
ResourceOptions.AssignedValues = [rvSilentMode]
ResourceOptions.SilentMode = True
UpdateOptions.AssignedValues = [uvCheckRequired, uvAutoCommitUpdates]
UpdateOptions.CheckRequired = False
UpdateOptions.AutoCommitUpdates = True
Left = 264
Top = 376
object strngfldmtb3brandname: TStringField
FieldName = 'brandname'
Size = 200
end
object strngfldmtb3brand: TStringField
FieldKind = fkLookup
FieldName = 'brand'
LookupDataSet = mtb2
LookupKeyFields = 'name'
LookupResultField = 'brand'
KeyFields = 'brandname'
Size = 200
Lookup = True
end
end
object bdr3: TBindSourceDB
DataSet = mtb3
ScopeMappings = <>
Left = 264
Top = 440
end
end
The error lies on the LookUp field I created in the FDMemTable (mtb3). I avoided those. Instead, I create a normal data field and directly took the data from TListView (lsv2) as shown below:
FMX Procedure
procedure TTabbedwithNavigationForm.btn1Click(Sender: TObject);
var
brandname, brand : string;
begin
brandname := mtb2.Lookup('name', lsv2.Items[lsv2.ItemIndex].Text, 'name');
brand := mtb2.Lookup('name', lsv2.Items[lsv2.ItemIndex].Text, 'brand');
if mtb3.Locate('brandname', brandname, []) = False then
begin
mtb3.DisableControls;
mtb3.Append;
mtb3.FieldByName('brandname').AsString := brandname;
mtb3.FieldByName('brand').AsString := brand; //manually coded instead of lookup field in the fdmemtable (mtb3)
mtb3.EnableControls;
mtb3.Post;
end;
end;
FMX File
object mtb3: TFDMemTable
Active = True
FieldDefs = <
item
Name = 'brandname'
DataType = ftString
Size = 200
end
item
Name = 'brand'
DataType = ftString // defined as data instead of lookup
Size = 100
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 = 264
Top = 376
object strngfldmtb3brandname: TStringField
FieldName = 'brandname'
Size = 200
end
object strngfldmtb3brand: TStringField
FieldName = 'brand'
Size = 100
end
end

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

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.

Delphi FMX ListView Filtered and FDQuery.First

I have a listview connected to a query where the user marks some records using the AccessoryObject. At the end of the process I make a while in the query checking which records have been marked and retrieve some query information. But when I do a search using the listview search box and use Query.First, the listview gets all blank and returns an access violation. Does anybody know how to solve this?
Link with minimal project
Project
Pas File:
unit Unit4;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
FMX.ListView.Types, FMX.ListView.Appearances, FMX.ListView.Adapters.Base,
FireDAC.Stan.Intf, FireDAC.Stan.Option, FireDAC.Stan.Param,
FireDAC.Stan.Error, FireDAC.DatS, FireDAC.Phys.Intf, FireDAC.DApt.Intf,
FireDAC.Stan.StorageBin, System.Rtti, System.Bindings.Outputs,
Fmx.Bind.Editors, Data.Bind.EngExt, Fmx.Bind.DBEngExt,
FMX.Controls.Presentation, FMX.StdCtrls, Data.Bind.Components,
Data.Bind.DBScope, Data.DB, FireDAC.Comp.DataSet, FireDAC.Comp.Client,
FMX.Layouts, FMX.ListView;
type
TForm4 = class(TForm)
ListView1: TListView;
Layout1: TLayout;
FDMemTable1: TFDMemTable;
FDMemTable1NAME: TStringField;
BindSourceDB1: TBindSourceDB;
BindingsList1: TBindingsList;
LinkListControlToField1: TLinkListControlToField;
Button1: TButton;
Label1: TLabel;
procedure ListView1ItemClick(const Sender: TObject;
const AItem: TListViewItem);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form4: TForm4;
implementation
{$R *.fmx}
procedure TForm4.Button1Click(Sender: TObject);
begin
FDMemTable1.First;
while not(FDMemTable1.Eof) do
Begin
if ListView1.Items.AppearanceItem[ListView1.Selected.Index].Objects.AccessoryObject.Visible then
Begin
//Do stuff
End;
FDMemTable1.Next;
End;
end;
procedure TForm4.ListView1ItemClick(const Sender: TObject;
const AItem: TListViewItem);
begin
AItem.Objects.AccessoryObject.Visible := not AItem.Objects.AccessoryObject.Visible;
end;
end.
FMX File
object Form4: TForm4
Left = 0
Top = 0
Caption = 'Form4'
ClientHeight = 480
ClientWidth = 640
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
DesignerMasterStyle = 0
object ListView1: TListView
ItemAppearanceClassName = 'TListItemAppearance'
ItemEditAppearanceClassName = 'TListItemShowCheckAppearance'
HeaderAppearanceClassName = 'TListHeaderObjects'
FooterAppearanceClassName = 'TListHeaderObjects'
ItemIndex = 0
Align = Client
Size.Width = 640.000000000000000000
Size.Height = 430.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
ItemAppearanceObjects.ItemObjects.Accessory.AccessoryType = Checkmark
ItemAppearanceObjects.ItemObjects.Accessory.Visible = False
OnItemClick = ListView1ItemClick
SearchVisible = True
end
object Layout1: TLayout
Align = Top
Size.Width = 640.000000000000000000
Size.Height = 50.000000000000000000
Size.PlatformDefault = False
TabOrder = 1
object Button1: TButton
Position.X = 24.000000000000000000
Position.Y = 16.000000000000000000
TabOrder = 0
Text = 'Do Stuff'
OnClick = Button1Click
end
object Label1: TLabel
Position.X = 112.000000000000000000
Position.Y = 19.000000000000000000
Size.Width = 377.000000000000000000
Size.Height = 17.000000000000000000
Size.PlatformDefault = False
Text = 'Search a name and click Do Stuff'
TabOrder = 1
end
end
object FDMemTable1: TFDMemTable
Active = True
FetchOptions.AssignedValues = [evMode]
FetchOptions.Mode = fmAll
ResourceOptions.AssignedValues = [rvPersistent, rvSilentMode]
ResourceOptions.Persistent = True
ResourceOptions.SilentMode = True
UpdateOptions.AssignedValues = [uvCheckRequired, uvAutoCommitUpdates]
UpdateOptions.CheckRequired = False
UpdateOptions.AutoCommitUpdates = True
Left = 304
Top = 274
Content = {
414442530F00922AE1010000FF00010001FF02FF03040016000000460044004D
0065006D005400610062006C006500310005000A0000005400610062006C0065
00060000000000070000080032000000090000FF0AFF0B0400080000004E0041
004D0045000500080000004E0041004D0045000C00010000000E000D000F0050
0000001000011100011200011300011400011500011600080000004E0041004D
004500170050000000FEFEFF18FEFF19FEFF1AFF1B1C0000000000FF1D000006
000000415254485552FEFEFF1B1C0001000000FF1D000005000000415843454C
FEFEFF1B1C0002000000FF1D000006000000414D414E4441FEFEFF1B1C000300
0000FF1D0000060000004153484C4559FEFEFF1B1C0004000000FF1D00000500
000042494E474FFEFEFF1B1C0005000000FF1D00000600000042554E4E4945FE
FEFF1B1C0006000000FF1D0000060000004341524C4F53FEFEFF1B1C00070000
00FF1D00000400000043415348FEFEFF1B1C0008000000FF1D00000600000043
414252414CFEFEFF1B1C0009000000FF1D00000600000044414C4C4153FEFEFF
1B1C000A000000FF1D000006000000454C4C494F54FEFEFF1B1C000B000000FF
1D0000050000004641425249FEFEFEFEFEFF1EFEFF1F20000C000000FF21FEFE
FE0E004D0061006E0061006700650072001E0055007000640061007400650073
005200650067006900730074007200790012005400610062006C0065004C0069
00730074000A005400610062006C00650008004E0061006D006500140053006F
0075007200630065004E0061006D0065000A0054006100620049004400240045
006E0066006F0072006300650043006F006E00730074007200610069006E0074
0073001E004D0069006E0069006D0075006D0043006100700061006300690074
007900180043006800650063006B004E006F0074004E0075006C006C00140043
006F006C0075006D006E004C006900730074000C0043006F006C0075006D006E
00100053006F0075007200630065004900440018006400740041006E00730069
0053007400720069006E00670010004400610074006100540079007000650008
00530069007A0065001400530065006100720063006800610062006C00650012
0041006C006C006F0077004E0075006C006C000800420061007300650014004F
0041006C006C006F0077004E0075006C006C0012004F0049006E005500700064
0061007400650010004F0049006E00570068006500720065001A004F00720069
00670069006E0043006F006C004E0061006D006500140053006F007500720063
006500530069007A0065001C0043006F006E00730074007200610069006E0074
004C00690073007400100056006900650077004C006900730074000E0052006F
0077004C00690073007400060052006F0077000A0052006F0077004900440010
004F0072006900670069006E0061006C001800520065006C006100740069006F
006E004C006900730074001C0055007000640061007400650073004A006F0075
0072006E0061006C001200530061007600650050006F0069006E0074000E0043
00680061006E00670065007300}
object FDMemTable1NAME: TStringField
FieldName = 'NAME'
Size = 80
end
end
object BindSourceDB1: TBindSourceDB
DataSet = FDMemTable1
ScopeMappings = <>
Left = 304
Top = 224
end
object BindingsList1: TBindingsList
Methods = <>
OutputConverters = <>
Left = 300
Top = 165
object LinkListControlToField1: TLinkListControlToField
Category = 'Quick Bindings'
DataSource = BindSourceDB1
FieldName = 'NAME'
Control = ListView1
FillExpressions = <>
FillHeaderExpressions = <>
FillBreakGroups = <>
end
end
end

Resources