unit ads_RTTI;
{Copyright(c)2016 Advanced Delphi Systems
Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
dickmaley@advdelphisys.com
The code herein can be used or modified by anyone. Please retain references
to Richard Maley at Advanced Delphi Systems. If you make improvements to the
code please send your improvements to dickmaley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
}
(*UnitIndex Master Index Implementation Section Download UnitsDescription: ads_RTTI.pas This unit contains the following routines.
TObject_Properties_ads.Execute TObject_Properties_ads.GetActive TObject_Properties_ads.GetCount TObject_Properties_ads.GetNames TObject_Properties_ads.GetObj TObject_Properties_ads.GetPropByName TObject_Properties_ads.GetXML
*)
interface
Uses
TypInfo, Classes;
Type
TPropertiesInfo = record
Default : Longint;
DefaultStr : String;
Index : Integer;
IndexStr : String;
IsPublished : Boolean;
IsPublishedStr: String;
Name : ShortString;
NameIndex : SmallInt;
NameIndexStr : String;
TypeKind : TTypeKind;
TypeName : String;
Value : String;
end;
TObject_Properties_ads = class
private
FActive : Boolean;
FObj : TObject;
FCount : Integer;
FPPropList : PPropList;
FProperties: Array of TPropertiesInfo;
FNames : TStringList;
function GetCount: Integer;
function GetObj: TObject;
function GetActive: Boolean;
function GetNames: TStringList;
function GetXML: String;
Public
Constructor Create;
destructor Destroy; override;
Function Execute(obj: TObject): Boolean;
Function GetPropByName(Name: String): TPropertiesInfo;
Published
property Active : Boolean Read GetActive;
property Obj : TObject Read GetObj;
property Count : Integer Read GetCount;
property Names : TStringList Read GetNames;
property XML : String Read GetXML;
End;
implementation
Uses
SysUtils, ads_Exception;
Var
ProcName : String = 'Unknown';
UnitName : String = 'ads_RTTI';
{ TObject_Properties_ads }
constructor TObject_Properties_ads.Create;
Var
ProcName : String;
begin
ProcName := 'TObject_Properties_ads.Create'; Try
inherited;
FObj := nil;
FCount := -1;
FActive := False;
FPPropList := nil;
FNames := TStringList.Create();
SetLength(FProperties,0);
Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
end;
destructor TObject_Properties_ads.Destroy;
Var
ProcName : String;
begin
ProcName := 'TObject_Properties_ads.Destroy'; Try
FNames.Free;
inherited;
Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
end;
//Unit Description UnitIndex Master Index
function TObject_Properties_ads.Execute(obj: TObject): Boolean;
Var
fl : Extended;
FPropInfo: PPropInfo;
i : Integer;
iMax : Integer;
iMin : Integer;
ProcName : String;
begin
Result := False;
ProcName := 'TObject_Properties_ads.Execute'; Try
Result := False;
Try
FObj := obj;
FCount := GetPropList(Fobj ,FPPropList);
SetLength(FProperties,FCount);
FNames.Clear;
iMin := 0;
iMax := Count-1;
For i := iMin To iMax Do
Begin
FPropInfo := FPPropList^[i];
FNames.Add(FPropInfo.Name);
FProperties[i].IsPublished := IsPublishedProp(FObj,FPropInfo.Name);
If FProperties[i].IsPublished Then
FProperties[i].IsPublishedStr := 'True'
Else
FProperties[i].IsPublishedStr := 'False';
If FPropInfo.Default = Low(LongInt) Then
FProperties[i].Default := -1
Else
FProperties[i].Default := FPropInfo.Default;
FProperties[i].DefaultStr := IntToStr(FProperties[i].Default);
If FPropInfo.Index = Low(LongInt) Then
FProperties[i].Index := -1
Else
FProperties[i].Index := FPropInfo.Index;
FProperties[i].IndexStr := IntToStr(FProperties[i].Index);
FProperties[i].Name := FPropInfo.Name;
FProperties[i].TypeName := FPPropList^[i].PropType^.Name;
FProperties[i].NameIndex := FPropInfo.NameIndex;
FProperties[i].NameIndexStr:= IntToStr(FProperties[i].NameIndex);
FProperties[i].TypeKind := FPPropList^[i].PropType^.Kind;
Case FProperties[i].TypeKind Of
tkUnknown : Try FProperties[i].Value := ''; Except End;
tkInteger : Try FProperties[i].Value := String(GetPropValue(FObj,FProperties[i].Name,True)); Except End;
tkChar : Try FProperties[i].Value := String(GetPropValue(FObj,FProperties[i].Name,True)); Except End;
tkEnumeration: Try FProperties[i].Value := GetEnumProp(FObj,FProperties[i].Name); Except End;
tkFloat :
Begin
Try
fl := GetFloatProp(FObj,FProperties[i].Name);
FProperties[i].Value := FormatFloat('#0.00000000000000000000',fl);
Except
End;
End;
tkString : Try FProperties[i].Value := GetStrProp(FObj,FProperties[i].Name); Except End;
tkSet : Try FProperties[i].Value := GetSetProp(FObj,FProperties[i].Name,True); Except End;
tkClass : Try FProperties[i].Value := String(GetPropValue(FObj,FProperties[i].Name,True)); Except End;
tkMethod : Try FProperties[i].Value := ''; Except End;
tkWChar : Try FProperties[i].Value := String(GetPropValue(FObj,FProperties[i].Name,True)); Except End;
tkLString : Try FProperties[i].Value := String(GetPropValue(FObj,FProperties[i].Name,True)); Except End;
tkWString : Try FProperties[i].Value := GetWideStrProp(FObj,FProperties[i].Name); Except End;
tkVariant : Try FProperties[i].Value := String(GetPropValue(FObj,FProperties[i].Name,True)); Except End;
tkArray : Try FProperties[i].Value := String(GetPropValue(FObj,FProperties[i].Name,True)); Except End;
tkRecord : Try FProperties[i].Value := String(GetPropValue(FObj,FProperties[i].Name,True)); Except End;
tkInterface : Try FProperties[i].Value := String(GetPropValue(FObj,FProperties[i].Name,True)); Except End;
tkInt64 : Try FProperties[i].Value := IntToStr(GetInt64Prop(FObj,FProperties[i].Name)); Except End;
tkDynArray : Try FProperties[i].Value := String(GetPropValue(FObj,FProperties[i].Name,True)); Except End;
End;
End;
FNames.Sort;
FActive := True;
Result := True;
Except
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
end;
//Unit Description UnitIndex Master Indexfunction TObject_Properties_ads.GetActive: Boolean; Var ProcName : String; begin Result := False; ProcName := 'TObject_Properties_ads.GetActive'; Try Result := FActive; Except On E : Exception Do RaiseError(UnitName,ProcName,E);End; end; //Unit Description UnitIndex Master Index
function TObject_Properties_ads.GetPropByName(
Name: String): TPropertiesInfo;
Var
i : Integer;
iMax : Integer;
iMin : Integer;
ProcName : String;
sgUName : String;
begin
ProcName := 'TObject_Properties_ads.GetPropByName'; Try
iMax := High(FProperties);
iMin := Low(FProperties);
sgUName := UpperCase(Name);
For i := iMin To iMax Do
Begin
If UpperCase(FProperties[i].Name)=sgUName Then
Begin
Result := FProperties[i];
Break;
End;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
End;
//Unit Description UnitIndex Master Indexfunction TObject_Properties_ads.GetCount: Integer; Var ProcName : String; begin Result := 0; ProcName := 'TObject_Properties_ads.GetCount'; Try Result := FCount; Except On E : Exception Do RaiseError(UnitName,ProcName,E);End; end; //Unit Description UnitIndex Master Index
function TObject_Properties_ads.GetNames: TStringList; Var ProcName : String; begin Result := nil; ProcName := 'TObject_Properties_ads.GetNames'; Try Result := FNames; Except On E : Exception Do RaiseError(UnitName,ProcName,E);End; end; //Unit Description UnitIndex Master Index
function TObject_Properties_ads.GetObj: TObject; Var ProcName : String; begin Result := nil; ProcName := 'TObject_Properties_ads.GetObj'; Try Result := FObj; Except On E : Exception Do RaiseError(UnitName,ProcName,E);End; end; //Unit Description UnitIndex Master Index
function TObject_Properties_ads.GetXML: String;
Var
EOL : String;
i : Integer;
iMax : Integer;
iMin : Integer;
p : String;
ProcName : String;
pubd : TStringList;
r : TPropertiesInfo;
sp : String;
unPub : TStringList;
begin
Result := '';
ProcName := 'TObject_Properties_ads.GetXML'; Try
pubd := TStringList.Create();
unPub:= TStringList.Create();
Try
sp := ' ';
EOL:= #13+#10;
pubd .Clear;
unPub.Clear;
iMax := High(FProperties);
iMin := Low(FProperties);
For i := iMin To iMax Do
Begin
If FProperties[i].IsPublished Then
pubd.Add(FProperties[i].Name)
Else
unPub.Add(FProperties[i].Name);
End;
pubd .Sort;
unPub.Sort;
p:=''+EOL;
Result := p;
Finally
pubd .Free;
unPub.Free;
End;
Except On E : Exception Do RaiseError(UnitName,ProcName,E);End;
end;
end.
//