i have a problem if i getting my defined type object.
I need to get my variables-defined object from a ListBox.
My data types:
type
TObjectData = class
Id: Integer;
DataType: String;
end;
TProjektInfo = record
Id: Integer;
Nazev: String;
end;
TReportSelect = record
Count: Integer;
Zakazka_Id: Integer;
Singles: Array of TProjektInfo;
Multies: Array of TProjektInfo;
end;
My procedure for fill listbox:
procedure TReportMain.VykresyFillProjectsList();
var
I,Id: Integer;
Nazev: String;
ItemData: TObjectData;
begin
VykresyProjectsListSections.Items.BeginUpdate;
VykresyProjectsListSections.Items.Clear;
for I := Low(ReportSelect.Singles) to High(ReportSelect.Singles) do
begin
Id := ReportSelect.Singles[I].Id;
Nazev := ReportSelect.Singles[I].Nazev;
ItemData := TObjectData.Create;
ItemData.Id := Id;
ItemData.DataType := 'single';
VykresyProjectsListSections.Items.AddObject(Nazev, TObject(ItemData));
ItemData.Free;
end;
for I := Low(ReportSelect.Multies) to High(ReportSelect.Multies) do
begin
Id := ReportSelect.Multies[I].Id;
Nazev := ReportSelect.Multies[I].Nazev;
ItemData := TObjectData.Create;
ItemData.Id := Id;
ItemData.DataType := 'multi';
VykresyProjectsListSections.Items.AddObject(Nazev, TObject(ItemData));
ItemData.Free;
end;
VykresyProjectsListSections.Items.EndUpdate;
end;
My button event on click for getting my datatype object (this is wrong where is commented):
procedure TReportMain.BtnExportProjectsClick(Sender: TObject);
var
ItemData: TObjectData;
Nazev: String;
I: Integer;
begin
ItemData := TObjectData.Create;
for I := 0 to VykresyProjectsListSections.Count - 1 do
begin
if VykresyProjectsListSections.Checked[I] then
begin
ItemData := TObjectData(VykresyProjectsListSections.Items.Objects[I]); // <--- This is wrong, why ?
Nazev := VykresyProjectsListSections.Items.Strings[I];
showMessage(Format('Nazev: %s ID: %d Type: %s', [Nazev, ItemData.Id, ItemData.DataType]));
end;
end;
end;
What happens to you is probably an access violation.
The variable you're trying to access is undefined because you have already freed the object the variable is pointing to.
In the code above, the ItemData object is always freed after it's added to the list.
You have to write some code to free the object when the list is cleared or freed.
This can be done in the OnDestroy event of your form:
procedure TReportMain.FormDestroy(Sender: TObject);
var
i: Integer;
begin
for i := VykresyProjectsListSections.Items.Count-1 downto 0 do begin
VykresyProjectsListSections.Items.Objects[i].Free;
VykresyProjectsListSections.Delete(i);
end;
VykresyProjectsListSections.Free;//free the list if not owned by the application
end;
As a side note, you can test if a TCheckListBox element is checked like this:
var
i: Integer;
begin
for i := 0 to VykresyProjectsListSections.Items.Count-1 do begin
if VykresyProjectsListSections.State[i] = cbChecked then
//do your stuff
end;
end;
You are calling ItemData.Free after AddObject(). This is wrong, since the object will not be valid anymore.
This will cause the error when later accessing the object in the CheckListBox.
Related
When looking to move the pointer on to the next record, an error message is shown that says:
Access violation at address 004070E2 in module 'main_p.exe'. Write of
address 00000000
Any way of resolving this?
var
i: integer;
begin
with dmData.dmEventInfo do
begin
tblEventinfo.Open;
i := 0;
while NOT tblEventinfo.Eof do
begin
arrNames[i] := tblEventinfo['bandname'];
tblEventinfo.Next;
i := i + 1;
end;
end;
end;
You don't show the declaration of the arrNames array , but I think the problem was in the Length.
var
i: integer; arrNames : array of string;
begin
SetLength(arrNames , tblEventinfo.RecordCount);
i := 0;
while NOT tblEventinfo.Eof do
begin
arrNames[i] := tblEventinfobandname.Value;
tblEventinfo.Next;
Inc(I);
end;
end;
The extended RTTI has the GetDeclaredProperties function which is exactly what i need, however i faced problems if i use the extended RTTI in multi-threading.
Therefore, i used GetPropList, but this gives me a list of all properties - not only published in the current class (or explicit stated).
i.e.
TBaseSettings = class(TPersistent)
published
property Charset: string read FCharset write FCharset;
end;
TBasicSettings = class(TBaseSettings)
published
property forums: Variant read fforums write fforums;
end;
TConcreteSettings = class(TBasicSettings)
published
property forums; // <-- make it explicit visible: OK
property prefix: Variant read fprefix write fprefix; // <-- OK
end;
I don't want to read the Charset property.
My first guess was to use a modified version of https://stackoverflow.com/a/1565686 to check for inheritance, but actually the forums property is also inherited.
Maybe this is not possible with the classic RTTI? I use Delphi 2010.
In case it's convenient to have your code calling GetDeclaredPropList in a similar way to calling GetPropList, see below.
Edit: I've rewritten the code in Delphi 7 and I believe it should work in Delphi 2010, too (which I don't have at hand).
type
PPropData = ^TPropData;
function AfterString(P: Pointer): Pointer;
begin
Result := Pointer(NativeUInt(P) + (PByte(P)^ + 1));
end;
function GetPropData(TypeData: PTypeData): PPropData;
begin
Result := AfterString(#TypeData^.UnitName);
end;
function NextPropInfo(PropInfo: PPropInfo): PPropInfo;
begin
Result := AfterString(#PropInfo^.Name);
end;
procedure GetDeclaredPropInfos(TypeInfo: PTypeInfo; PropList: PPropList);
var
TypeData: PTypeData;
PropData: PPropData;
PropInfo: PPropInfo;
I: Integer;
begin
TypeData := GetTypeData(TypeInfo);
PropData := GetPropData(TypeData);
FillChar(PropList^, Sizeof(PPropInfo) * PropData^.PropCount, 0);
PropInfo := PPropInfo(#PropData^.PropList);
for I := 0 to PropData^.PropCount - 1 do
begin
PropList^[I] := PropInfo;
PropInfo := NextPropInfo(PropInfo);
end;
end;
function GetDeclaredPropList(TypeInfo: PTypeInfo; out PropList: PPropList): Integer; overload;
begin
Result := GetPropData(GetTypeData(TypeInfo))^.PropCount;
if Result > 0 then
begin
GetMem(PropList, Result * SizeOf(Pointer));
GetDeclaredPropInfos(TypeInfo, PropList);
end;
end;
function GetDeclaredPropList(AObject: TObject; out PropList: PPropList): Integer; overload;
begin
Result := GetDeclaredPropList(PTypeInfo(AObject.ClassInfo), PropList);
end;
// example usage:
var
I, Count: Integer;
PropList: PPropList;
PropInfo: PPropInfo;
begin
Count := GetDeclaredPropList(TypeInfo(TConcreteSettings), PropList);
try
for I := 0 to Count - 1 do
begin
PropInfo := PropList^[I];
Writeln(PropInfo^.Name);
end;
finally
FreeMem(PropList);
end;
end.
var
TypeData: PTypeData;
PropData: PPropData;
PropInfo: PPropInfo;
I: Integer;
begin
TypeData := GetTypeData(TypeInfo(TConcreteSettings));
PropData := GetPropData(TypeData);
if Assigned(PropData) then
begin
PropInfo := #PropData^.PropList;
for I := 0 to PropData^.PropCount - 1 do
begin
Writeln(PropInfo^.Name);
PropInfo := NextPropInfo(PropInfo);
end;
end;
end;
For implementation of GetPropData and NextPropInfo see my other answer above.
I have a procedure that needs to insert an array of TObjects into to a list. The list can be of any of the supported types, e.g. TObjectList, TObjectList<T>, TROArray, etc.
The procedure looks like this:
type
TObjectArray = Array of TObject;
...
procedure TMyClass.DoAssignObjectList(const ObjectArray: TObjectArray;
const DstList: TObject);
var
i: Integer;
begin
if DstList is TObjectList then
begin
for i := 0 to pred(TObjectList(DstList).Count) do
TObjectList(DstList).Add(ObjectArray[i]);
end else
if DstList is TObjectList<T> then // Obviously this doesn't work
begin
for i := 0 to pred(TObjectList<T>(DstList).Count) do
TObjectList<T>(DstList).Add(ObjectArray[i]);
end
else
begin
raise Exception.CreateFmt(StrNoDoAssignORMObject, [DstList.ClassName]);
end;
end;
How can I check that an object is a TObjectList<T> and then add the elements of an array to it?
You have to use a bit RTTI to get some more information about the generic type.
The following code uses Spring4D which has some methods for that:
uses
...
Spring.Reflection;
procedure DoAssignObjectList(const ObjectArray: TObjectArray;
const DstList: TObject);
function IsGenericTObjectList(const obj: TObject): Boolean;
var
t: TRttiType;
begin
t := TType.GetType(obj.ClassInfo);
Result := t.IsGenericType and (t.GetGenericTypeDefinition = 'TObjectList<>');
end;
begin
...
if IsGenericTObjectList(DstList) then
begin
for i := 0 to pred(TObjectList<TObject>(DstList).Count) do
TObjectList<TObject>(DstList).Add(ObjectArray[i]);
...
end;
Additionally to that you can also get information about the generic parameter type of the list to check if the objects you are putting into it are matching the requirements (only works on a generic type of course):
function GetGenericTObjectListParameter(const obj: TObject): TClass;
var
t: TRttiType;
begin
t := TType.GetType(obj.ClassInfo);
Result := t.GetGenericArguments[0].AsInstance.MetaclassType;
end;
As I was writing this question I figured out a way to do this using RTTI. It should work with any list that has a procedure Add(AObject: TObject).
procedure TransferArrayItems(const Instance: TObject;
const ObjectArray: TObjectArray);
const
AddMethodName = 'Add';
var
Found: Boolean;
LMethod: TRttiMethod;
LIndex: Integer;
LParams: TArray<TRttiParameter>;
i: Integer;
RTTIContext: TRttiContext;
RttiType: TRttiType;
begin
Found := False;
LMethod := nil;
if length(ObjectArray) > 0 then
begin
RTTIContext := TRttiContext.Create;
RttiType := RTTIContext.GetType(Instance.ClassInfo);
for LMethod in RttiType.GetMethods do
begin
if SameText(LMethod.Name, AddMethodName) then
begin
LParams := LMethod.GetParameters;
if length(LParams) = 1 then
begin
Found := TRUE;
for LIndex := 0 to length(LParams) - 1 do
begin
if LParams[LIndex].ParamType.Handle <> TValue(ObjectArray[0]).TypeInfo
then
begin
Found := False;
Break;
end;
end;
end;
if Found then
Break;
end;
end;
if Found then
begin
for i := Low(ObjectArray) to High(ObjectArray) do
begin
LMethod.Invoke(Instance, [ObjectArray[i]]);
end;
end
else
begin
raise Exception.CreateFmt(StrMethodSNotFound, [AddMethodName]);
end;
end;
end;
I want to implement a sortable DBgrid (that sorts its rows when clicked on column title). I managed to make it sortable in an ascending order but I can't do it in a descending order. Here are my design settings:
Query1.DatabaseName:='Test';
DataSetProvider1.DataSet:=Query1;
ClientDataSet1.ProviderName:=DataSetProvider1;
DataSource1.DataSet:=ClientDataSet1;
DBGrid1.DatSource:=DataSource1;
And here are fragments of my code:
procedure TForm2.FormShow(Sender: TObject);
begin
Query1.Open;
ClientDataSet1.Data:=DataSetProvider1.Data;
ClientDataSet1.AddIndex('objnameDESC','objname',[ixDescending]);
ClientDataSet1.AddIndex('SUM(cd.worktime)DESC','SUM(cd.worktime)',[ixDescending]);
end;
procedure TForm2.DBGrid1TitleClick(Column: TColumn);
begin
case Column.Index of
0: if ClientDataSet1.IndexFieldNames='objname' then
ClientDataSet1.IndexFieldNames:='objnameDESC'
else
ClientDataSet1.IndexFieldNames:='objname';
1: if ClientDataSet1.IndexFieldNames='SUM(cd.worktime)' then
ClientDataSet1.IndexFieldNames:='SUM(cd.worktime)DESC'
else
ClientDataSet1.IndexFieldNames:='SUM(cd.worktime)';
end;
end;
When I click on a column title for the first time, sorting is done in an ascending order - so up to here everything is OK. When I click for the second time I expect sorting in a descending order to be done but instead I get the message:
Project ... raised Exception class EDatabaseError with message
'ClientDataSet1: Field 'objnameDESC' not found'.
Any ideas about what I am doing wrong?
As you are already using TClientDataSet you might make use of a component I made for exactly that purpose. Create an instance, set its Grid property and it will automatically connect to the OnTitleClick event.
type
TDBGridSorter = class(TComponent)
strict private
FSortColumn: TColumn;
FGrid: TDBGrid;
procedure CreateIndex(const FieldName: string; Descending: Boolean);
function GetDataSet: TClientDataSet;
function MakeIndexName(const FieldName: string; Descending: Boolean): string;
procedure SetSortColumn(const Value: TColumn);
procedure SortByField(const FieldName: string; out Descending: Boolean);
private
procedure SetGrid(const Value: TDBGrid);
strict protected
procedure GridTitleClick(Column: TColumn);
property DataSet: TClientDataSet read GetDataSet;
public
property Grid: TDBGrid read FGrid write SetGrid;
property SortColumn: TColumn read FSortColumn write SetSortColumn;
end;
procedure TDBGridSorter.CreateIndex(const FieldName: string; Descending: Boolean);
var
cds: TClientDataSet;
indexDef: TIndexDef;
indexName: string;
begin
cds := DataSet;
if cds <> nil then begin
indexName := MakeIndexName(FieldName, Descending);
if cds.IndexDefs.IndexOf(indexName) < 0 then begin
indexDef := cds.IndexDefs.AddIndexDef;
indexDef.Name := indexName;
indexDef.Fields := FieldName;
indexDef.CaseInsFields := FieldName;
if Descending then
indexDef.DescFields := FieldName;
end;
end;
end;
function TDBGridSorter.GetDataSet: TClientDataSet;
begin
if (Grid <> nil) and (Grid.DataSource <> nil) and (Grid.DataSource.DataSet is TClientDataSet) then
Result := TClientDataSet(Grid.DataSource.DataSet)
else
Result := nil;
end;
procedure TDBGridSorter.GridTitleClick(Column: TColumn);
begin
SortColumn := Column;
end;
function TDBGridSorter.MakeIndexName(const FieldName: string; Descending: Boolean): string;
const
cAscDesc: array[Boolean] of string = ('_ASC', '_DESC');
begin
Result := FieldName + cAscDesc[Descending];
end;
procedure TDBGridSorter.SetGrid(const Value: TDBGrid);
begin
if FGrid <> Value then begin
if FGrid <> nil then begin
FGrid.OnTitleClick := nil;
FGrid.RemoveFreeNotification(Self);
end;
FGrid := Value;
if FGrid <> nil then begin
FGrid.FreeNotification(Self);
FGrid.OnTitleClick := GridTitleClick;
end;
end;
end;
procedure TDBGridSorter.SetSortColumn(const Value: TColumn);
const
cOrder: array[Boolean] of string = ('˄', '˅');
var
descending: Boolean;
S: string;
begin
if FSortColumn <> nil then begin
S := FSortColumn.Title.Caption;
if StartsStr(cOrder[false], S) or StartsStr(cOrder[true], S) then begin
Delete(S, 1, 2);
FSortColumn.Title.Caption := S;
end;
end;
FSortColumn := Value;
if FSortColumn <> nil then begin
SortByField(FSortColumn.FieldName, descending);
FSortColumn.Title.Caption := Format('%s %s', [cOrder[descending], FSortColumn.Title.Caption]);
end;
end;
procedure TDBGridSorter.SortByField(const FieldName: string; out Descending:
Boolean);
var
cds: TClientDataSet;
curIndex: TIndexDef;
N: Integer;
begin
cds := DataSet;
if cds <> nil then begin
descending := false;
N := cds.IndexDefs.IndexOf(cds.IndexName);
if N >= 0 then begin
curIndex := cds.IndexDefs[N];
if SameText(FieldName, curIndex.Fields) then
descending := not (ixDescending in curIndex.Options)
end;
{ make sure the index exists }
CreateIndex(FieldName, descending);
cds.IndexName := MakeIndexName(FieldName, descending);
end;
end;
Wrong assignment
Apart from the fact that an incorrect assignment is made, a switch back to "ascending" is not possible.
For 2 Colums you need 4 Indexes.
Assuming 'objname' and 'SUM(cd.worktime)' are Fields.
procedure TForm2.FormShow(Sender: TObject);
....
ClientDataSet1.AddIndex('col0_asc','objname',[]);
ClientDataSet1.AddIndex('col0_desc','objname',[ixDescending]);
ClientDataSet1.AddIndex('col1_asc','SUM(cd.worktime)',[]);
ClientDataSet1.AddIndex('col1_desc','SUM(cd.worktime)',[ixDescending]);
....
Use ClientDataSet1.IndexName
procedure TForm2.DBGrid1TitleClick(Column: TColumn);
begin
case Column.Index of
0: if ClientDataSet1.IndexName='col0_asc' then
ClientDataSet1.IndexName:='col0_desc'
else
ClientDataSet1.IndexName:='col0_asc';
1: if ClientDataSet1.IndexName='col1_asc' then
ClientDataSet1.IndexName:='col1_desc'
else
ClientDataSet1.IndexName:='col1_asc';
end;
....
Or shorter
procedure TForm2.DBGrid1TitleClick(Column: TColumn);
begin
if ClientDataSet1.IndexName='col'+IntToStr(Column.Index)+'_asc' then
ClientDataSet1.IndexName:='col'+IntToStr(Column.Index)+'_desc'
else
ClientDataSet1.IndexName:='col'+IntToStr(Column.Index)+'_asc';
....
But it is better to test the number of columns that are active (AddIndex = done).
procedure TForm2.DBGrid1TitleClick(Column: TColumn);
begin
if Column.Index < 2 then begin
if ClientDataSet1.IndexName='col'+IntToStr(Column.Index)+'_asc' then
ClientDataSet1.IndexName:='col'+IntToStr(Column.Index)+'_desc'
else
ClientDataSet1.IndexName:='col'+IntToStr(Column.Index)+'_asc';
end;
....
You should be setting the IndexName and not IndexFieldNames. IndexFieldNames accepts field names and creates an index on the fly.
procedure TForm2.DBGrid1TitleClick(Column: TColumn);
begin
case Column.Index of
0: if ClientDataSet1.IndexFieldNames='objname' then
ClientDataSet1.IndexName:='objnameDESC'
else
ClientDataSet1.IndexFieldNames:='objname';
1: if ClientDataSet1.IndexFieldNames='SUM(cd.worktime)' then
ClientDataSet1.IndexFieldNames:='SUM(cd.worktime) DESC'
else
ClientDataSet1.IndexFieldNames:='SUM(cd.worktime)';
end;
end;
Many of my programs need this, so I wrote a general procedure which builds two indices for each field in the dataset
Procedure BuildIndices (cds: TClientDataSet);
var
i, j: integer;
alist: tstrings;
begin
with cds do
begin
open;
for i:= 0 to FieldCount - 1 do
if fields[i].fieldkind <> fkCalculated then
begin
j:= i * 2;
addindex ('idx' + inttostr (j), fieldlist.strings[i], [], '', '', 0);
addindex ('idx' + inttostr (j+1), fieldlist.strings[i], [ixDescending], '', '',0);
end;
alist:= tstringlist.create;
getindexnames (alist);
alist.free;
close;
end;
end;
At this stage, I have indices idx0 and idx1 for the first field, idx2 and idx3 for the second field, etc.
Then, in the form which displays the dbgrid (here the active query is called qShowFees)
procedure TShowFees.DBGrid1TitleClick(Column: TColumn);
var
n, ex: word;
begin
n:= column.Index;
try
dbGrid1.columns[prevcol].title.font.color:= clNavy
except
end;
dbGrid1.columns[n].title.font.color:= clRed;
prevcol:= n;
directions[n]:= not directions[n];
ex:= n * 2;
if directions[n] then inc (ex);
with qShowFees do
try
disablecontrols;
close;
indexname:= 'idx' + inttostr (ex);
open
finally
enablecontrols
end;
end;
'Directions' is a form array of booleans which 'remembers' which way each column is currently sorted (ascending or descending) so clicking the dbgrid's title bar a second time will cause the grid to be sorted in the opposing manner to which it was sorted before. 'Prevcol' is a form variable which stores the currently selected column; this is saved between invocations, so the next time the user opens the form, it is sorted in the same way as she left it previously.
I'm trying to invoke a constructor obtained via RTTI (running D2010 version 14.0.3593.25826). The constructor takes a mixture of strings and objects as its arguments, all of which should be initialized to '' or nil. (Disclaimer: I know that the desired constructor will be the one with maximum number of parameters, hence the weird-looking, although suboptimal design.)
The code goes as follows:
program sb_rtti;
{$APPTYPE CONSOLE}
uses RTTI, TypInfo, SysUtils;
type
TMyClass = class (TObject)
FField1: string;
FObject1: TObject;
public
constructor Create(Field1: string = ''; Object1: TObject = nil);
end;
constructor TMyClass.Create(Field1: string; Object1: TObject);
begin
FField1 := Field1;
FObject1 := Object1;
end;
function GetConstructor(rType: TRttiType) : TRttiMethod;
var
MaxParams: integer;
Methods: TArray<TRttiMethod>;
Method: TRttiMethod;
Params: TArray<TRttiParameter>;
begin
Methods := rType.GetMethods('Create');
MaxParams := 0;
for Method in Methods do begin
Params := Method.GetParameters();
if (Length(Params) > MaxParams) then begin
Result := Method;
MaxParams := Length(Params);
end;
end;
end;
procedure InitializeParam(Param: TRttiParameter; ActualParam: TValue);
begin
if (Param.ParamType.TypeKind = TTypeKind.tkClass) then begin
ActualParam := TValue.From<TObject>(nil);
end else if (Param.ParamType.TypeKind = TTypeKind.tkString) then begin
ActualParam := TValue.From<string>('');
end else if (Param.ParamType.TypeKind = TTypeKind.tkUString) then begin
ActualParam := TValue.From<UnicodeString>('');
end else begin
// Other types goes here
end;
end;
var
Context: TRttiContext;
Constr: TRttiMethod;
Params: TArray<TRttiParameter>;
ResultValue: TValue;
rType: TRttiType;
ActualParams: array of TValue;
i: integer;
CurrentParam: TRttiParameter;
begin
Context := TRttiContext.Create();
rType := Context.GetType(TypeInfo(TMyClass));
Constr := GetConstructor(rType);
try
if (Constr <> nil) then begin
Params := Constr.GetParameters();
SetLength(ActualParams, Length(Params));
for i := 0 to Length(Params) - 1 do begin
CurrentParam := Params[i] as TRttiParameter;
InitializeParam(CurrentParam, ActualParams[i]);
end;
ResultValue := Constr.Invoke(rType.AsInstance.MetaclassType, ActualParams);
end;
except
on E : Exception do
WriteLn(E.ToString);
end;
ReadLn;
end.
Now, when the line ResultValue := Constr.Invoke(rType.AsInstance.MetaclassType, ActualParams); is executed, an EInvalidCast exception is raised. The exception may be traced to the TValue.Cast-method at line 1336.
However, the meat of the problem seems to be found at the previous point in the call stack, more precisely at line 4093 in rtti.pas (argList[currArg] := Args[i].Cast(parList[i].ParamType.Handle);).
My bet is that I'm using rtti in ways I'm not supposed to, yet, I can't find the "right way" described anywhere. Can anybody please point me in the right direction? Thanks!
You have a problem in the InitializeParam procedure because in the assignment of the ActualParam parameter, you are setting the value of the local copy of that parameter – remember that TValue (the type of ActualParam) is a record. So to fix the problem you must pass the ActualParam as a var parameter.
procedure InitializeParam(Param: TRttiParameter; var ActualParam: TValue);
It just occurred to me to hard-code the argument initialization by replacing
for i := 0 to Length(Params) - 1 do begin
CurrentParam := Params[i] as TRttiParameter;
InitializeParam(CurrentParam, ActualParams[i]);
end;
with
ActualParams[0] := TValue.From<string>('');
ActualParams[1] := TValue.From<TObject>(nil);
which solves the problem.