unit  FieldInfo;

 interface 

 uses 
  Windows, Messages, SysUtils, Classes, Db, DbClient;

 type 
  PFieldProps = ^TFieldProps;
  TFieldProps =  record 
    FieldName:  string ;
    ClassType: TFieldClass;
    MemoryStream: TMemoryStream;
    LookUpDataSet: TDataSet;
   end ;

   {New: Add Calculated fields} 
 procedure  AddCalculatedFields(Dataset: TDataSet;  const  FieldsNames,
  FieldsTypes:  array   of   string );
 {New: Assign data and Fields to new structure} 
 {With this function you can add Data Field (not calculated) to client dataset
but this function is slow and heavy} 
 procedure  AssignData(List: TList; Dataset: TClientDataSet);
 {Streams Fields List Clear} 
 procedure  ClearAllFieldsInfo(List: TList);
 {New: Copy Old Data in Modified Dataset} 
 procedure  CopyDatasetData(Source, Target: TDataSet);
 {New: delete an Item from List} 
 procedure  DeleteField(List: TList; index: integer);
 {Get information about Field definition into Dataset and then put into List} 
 procedure  GetAllFieldsInfo(List: TList; DataSet: TDataSet);
 {Get information about one Field and then put into List} 
 procedure  GetFieldInfo(List: TList; Field: TField);
 {New:  get the FieldIndex of Item} 
 function  GetFieldIndex(List: TList; FieldName:  string ): integer;
 {New:  get the FieldName of Item} 
 function  GetFieldName(List: TList; index: integer):  string ;
 {Get information about Field definition into Stream List and then put into Dataset} 
 procedure  SetAllFieldsInfo(List: TList; DataSet: TDataSet);
 {Field Classes register} 
 procedure  RegClasses;
 {Field Classes Unregister} 
 procedure  UnRegClasses;

 implementation 

 uses 
  Variants;

 procedure  AddCalculatedFields(Dataset: TDataSet;  const  FieldsNames,
  FieldsTypes:  array   of   string );
 var 
  List: TList;
  i: integer;
  oField: TField;
  clFieldClass: TFieldClass;
 begin 
   if   not  DataSet.Active  then 
     raise  Exception.Create('I can not create calculated Fields when dataset is closed' + # 13 
      + 'with function AddCalculatedFields')
   else 
   begin 
    List := TList.Create;
    GetAllFieldsInfo(List, DataSet);
     for  i := Low(FieldsNames)  to  High(FieldsNames)  do 
       if   not  Assigned(Dataset.FindField(FieldsNames))  then 
       begin 
        clFieldClass := TFieldClass(GetClass(FieldsTypes[i]));
        oField := clFieldClass.Create(DataSet);
        oField.FieldName := FieldsNames[i];
        oField.Calculated := True;
         if  oField  is  TStringField  then 
          oField.Size :=  100 ;  [i]{!!!} 
        oField.FieldKind := fkInternalCalc;
        GetFieldInfo(List, oField);
        oField.Free;
       end ;
    DataSet.Close;
    SetAllFieldsInfo(List, DataSet);
    ClearAllFieldsInfo(List);
    List.Free;
    DataSet.Open;
   end ;
 end ;

 procedure  AssignData(List: TList; Dataset: TClientDataSet);
 var 
  NewDs: TClientDataSet;
 begin 
  DataSet.DisableControls;
  NewDs := TClientDataSet.Create( nil );
  SetAllFieldsInfo(List, NewDs);
  NewDs.CreateDataSet;
  CopyDatasetData(Dataset, NewDs);
  Dataset.Data := Null;
  SetAllFieldsInfo(List, DataSet);
  Dataset.Data := NewDs.Data;
  NewDs.Data := Null;
  NewDs.Free;
  DataSet.EnableControls;
 end ;

 procedure  ClearAllFieldsInfo(List: TList);
 var 
  i: Integer;
 begin 
   {Free record in each element of list} 
   for  i :=  0   to  List.Count -  1   do 
   begin 
    TFieldProps(List^).MemoryStream.Free;
    TFieldProps(List[i]^).ClassType :=  nil ;
    TFieldProps(List[i]^).LookUpDataSet :=  nil ;
    Dispose(List[i]);
   end ;
   [i]{Clear the List} 
  List.Clear;
 end ;

 procedure  CopyDatasetData(Source, Target: TDataSet);
 type 
  TSourceTargetFields =  array [ 0 .. 1 ]  of  TField;
 var 
  i, index: Integer;
  aFields:  array   of  TSourceTargetFields;
  oField: TField;
 begin 
   if   not  Source.Active  then 
    Source.Active := True;
   if   not  Target.Active  then 
    Target.Active := True;
   for  i :=  0   to  Source.FieldCount -  1   do 
   begin 
    oField := Target.FindField(Source.Fields.FieldName);
     if  oField <>  nil   then 
     begin 
      index := High(aFields) +  1 ;
      SetLength(aFields, index +  1 );
      aFields[index][ 0 ] := Source.Fields[i];
      aFields[index][ 1 ] := oField;
     end ;
   end ;

  Source.First;
   while   not  Source.Eof  do 
   begin 
    Target.Insert;
     for  i :=  0   to  High(aFields)  do 
     begin 
      aFields[i][ 1 ].Value := aFields[i][ 0 ].Value;
     end ;
    Target.Post;
    Source.Next;
   end ;
 end ;

 procedure  DeleteField(List: TList; index: integer);
 begin 
   if  index < List.Count  then 
   begin 
    TFieldProps(List[index]^).MemoryStream.Free;
    TFieldProps(List[index]^).ClassType :=  nil ;
    TFieldProps(List[index]^).LookUpDataSet :=  nil ;
    Dispose(List[index]);
    List.Delete(index);
   end ;
 end ;

 procedure  GetAllFieldsInfo(List: TList; DataSet: TDataSet);
 var 
  i: Integer;
  Field: TField;
 begin 
   for  i :=  0   to  DataSet.Fields.Count -  1   do 
   begin 
    Field := DataSet.Fields[i];
     [i]{Put Field information into list} 
    GetFieldInfo(List, Field)
   end ;
 end ;

 procedure  GetFieldInfo(List: TList; Field: TField);
 var 
  FieldProps: PFieldProps;
  i: integer;
 begin 
  New(FieldProps);

   {FieldName is necesary to compare if exist into the list} 
  FieldProps^.FieldName := Field.FieldName;
  FieldProps^.ClassType := TFieldClass(Field.ClassType);
  FieldProps^.MemoryStream := TMemoryStream.Create;
  FieldProps^.MemoryStream.WriteComponent(Field);
   {LookUpDataSet is necesary because is a pointer and WriteComponent do not keep this information} 
  FieldProps^.LookUpDataSet := Field.LookupDataSet;

   for  i :=  0   to  List.Count -  1   do 
   begin 
     if  TFieldProps(List^).FieldName = FieldProps^.FieldName  then 
     begin 
       [i]{if exist into list then delete it} 
      TFieldProps(List^).MemoryStream.Free;
      TFieldProps(List[i]^).ClassType :=  nil ;
      TFieldProps(List[i]^).LookUpDataSet :=  nil ;
      Dispose(List[i]);
      List.Delete(i);
      Break;
     end ;
   end ;

   [i]{Add information into the list} 
  List.Add(FieldProps);
 end ;

 function  GetFieldIndex(List: TList; FieldName:  string ): integer;
 var 
  i: integer;
 begin 
  result := - 1 ;
   for  i :=  0   to  List.Count -  1   do 
   begin 
     if  AnsiCompareText(PFieldProps(List).FieldName, FieldName) =  0   then 
     begin 
      result := i;
      Break;
     end ;
   end ;
 end ;

 function  GetFieldName(List: TList; index: integer):  string ;
 begin 
   if  index < List.Count  then 
    result := PFieldProps(List[index]).FieldName
   else 
    result := '';
 end ;

 procedure  SetAllFieldsInfo(List: TList; DataSet: TDataSet);
 var 
  i: Integer;
  LocalField: TField;
  FieldClass: TFieldClass;
  SourceInfo: TMemoryStream;
 begin 
   if  DataSet.Active  then 
    DataSet.Active := False;

   [i]{se recorre toda la lista de definiciones de campos} 
  DataSet.Fields.Clear;
  DataSet.FieldDefs.Clear;

   {Add all List Field definition into List to DataSet} 
   for  i :=  0   to  List.Count -  1   do 
   begin 
     {Get Correct Class Type} 
    FieldClass := TFieldProps(List^).ClassType;

     [i]{if Class exists} 
     if  FieldClass <>  nil   then 
     begin 
       {Goto the first position of stream} 
      SourceInfo := TFieldProps(List^).MemoryStream;
      SourceInfo.Seek( 0 , soFromBeginning);

       [i]{Create Field with Dataset} 
      LocalField := FieldClass.Create(DataSet);
       {Set Field information} 
      LocalField := TField(SourceInfo.ReadComponent(LocalField));
       {Assign DataSet to Field} 
      LocalField.DataSet := DataSet;
      LocalField.LookupDataSet := TFieldProps(List^).LookUpDataSet;

       [i]//      if FieldClass=TStringField then LocalField.Size:=100; {!!!} 
     end ;
   end ;
 end ;

 procedure  RegClasses;
 var 
  AFieldClasses:  array [ 0 .. 25 ]  of  TPersistentClass;
 begin 
  AFieldClasses[ 0 ] := TADTField;
  AFieldClasses[ 1 ] := TAggregateField;
  AFieldClasses[ 2 ] := TArrayField;
  AFieldClasses[ 3 ] := TAutoIncField;
  AFieldClasses[ 4 ] := TBCDField;
  AFieldClasses[ 5 ] := TBinaryField;
  AFieldClasses[ 6 ] := TBlobField;
  AFieldClasses[ 7 ] := TBooleanField;
  AFieldClasses[ 8 ] := TBytesField;
  AFieldClasses[ 9 ] := TCurrencyField;
  AFieldClasses[ 10 ] := TDateField;
  AFieldClasses[ 11 ] := TDataSetField;
  AFieldClasses[ 12 ] := TDateTimeField;
  AFieldClasses[ 13 ] := TFloatField;
  AFieldClasses[ 14 ] := TGraphicField;
  AFieldClasses[ 15 ] := TIntegerField;
  AFieldClasses[ 16 ] := TLargeintField;
  AFieldClasses[ 17 ] := TMemoField;
  AFieldClasses[ 18 ] := TNumericField;
  AFieldClasses[ 19 ] := TObjectField;
  AFieldClasses[ 20 ] := TReferenceField;
  AFieldClasses[ 21 ] := TSmallintField;
  AFieldClasses[ 22 ] := TStringField;
  AFieldClasses[ 23 ] := TTimeField;
  AFieldClasses[ 24 ] := TVarBytesField;
  AFieldClasses[ 25 ] := TWordField;
  RegisterClasses(AFieldClasses);
 end ;

 procedure  UnRegClasses;
 var 
  AFieldClasses:  array [ 0 .. 25 ]  of  TPersistentClass;
 begin 
  AFieldClasses[ 0 ] := TADTField;
  AFieldClasses[ 1 ] := TAggregateField;
  AFieldClasses[ 2 ] := TArrayField;
  AFieldClasses[ 3 ] := TAutoIncField;
  AFieldClasses[ 4 ] := TBCDField;
  AFieldClasses[ 5 ] := TBinaryField;
  AFieldClasses[ 6 ] := TBlobField;
  AFieldClasses[ 7 ] := TBooleanField;
  AFieldClasses[ 8 ] := TBytesField;
  AFieldClasses[ 9 ] := TCurrencyField;
  AFieldClasses[ 10 ] := TDateField;
  AFieldClasses[ 11 ] := TDataSetField;
  AFieldClasses[ 12 ] := TDateTimeField;
  AFieldClasses[ 13 ] := TFloatField;
  AFieldClasses[ 14 ] := TGraphicField;
  AFieldClasses[ 15 ] := TIntegerField;
  AFieldClasses[ 16 ] := TLargeintField;
  AFieldClasses[ 17 ] := TMemoField;
  AFieldClasses[ 18 ] := TNumericField;
  AFieldClasses[ 19 ] := TObjectField;
  AFieldClasses[ 20 ] := TReferenceField;
  AFieldClasses[ 21 ] := TSmallintField;
  AFieldClasses[ 22 ] := TStringField;
  AFieldClasses[ 23 ] := TTimeField;
  AFieldClasses[ 24 ] := TVarBytesField;
  AFieldClasses[ 25 ] := TWordField;
  UnRegisterClasses(AFieldClasses);
 end ;

 initialization 
  RegClasses;

 finalization 
  UnRegClasses;
 end .