How to use BDE dbiDoRestructure to add fields in Delphi 10.4?

Question

I am trying to make a function to add / delete / modify fields of Paradox Tables using BDE.dbiDoRestructure (see my other question BDE dbidorestructure returns empty table), but while I get the Table restructured properly and the grid shows the correct number of data-rows, all its data cells are empty.

Answer 1

Here is the unit I built (Delphi 10.4, Win 10/64) to test and rebuild a BDE TTable (Paradox, DB, FOXpro). It has the ability to open / create, check and reconstruct the table (fields and indexes) and visualize the progress. You can use / improve it freely.

{
based on
http://www.delphigroups.info/2/5a/37309.html
and TFieldUpdate v1.1 by Nathanial Woolls [email protected]
and MartynA suggestions
at https://stackoverflow.com/questions/66851948/how-to-use-bde-dbidorestructure-to-add-fields-in-delphi-10-4/66852904?noredirect=1#comment118324077_66852904
}

unit OpenCheckTable;

interface

uses
  windows,SysUtils, Classes, bde, Dialogs, db, TypInfo, dbtables, inifiles,


scktcomp, stdctrls, comctrls, DBCommonTypes, forms, Gauges,
  shellAPI,Zlibx,ZipedBLOB;

    type

      TfooClass = class(TComponent)
  private
    { Private declarations }
  protected
    { Protected declarations }
    function ProgressCallback(CBInfo: Pointer): CBRType;
  public
    { Public declarations }
  published
    { Published declarations }
  end;


function openORcreateTable(T: TTable; L: TLabel; Bar : TGauge): boolean; overload;

implementation

var nRecords        : integer;
    QuickProgress   : TGauge;
    fooClass        : TfooClass;

function TfooClass.ProgressCallback(CBInfo: Pointer): CBRType;
var x : string;
begin
    if pCBPROGRESSDesc(cbInfo).iPercentDone < 0 then begin
        x := pCBPROGRESSDesc(cbInfo).szMsg;
        Delete(x, 1, Pos(': ', x) + 1) ;
        try
            QuickProgress.Progress := Round((StrToInt(trim(x)) / nRecords) * 100);
        except
        end;
    end
    else
    QuickProgress.Progress := pCBPROGRESSDesc(cbInfo).iPercentDone;
    application.ProcessMessages;
    result := cbrCONTINUE;
end;

//*******************************************************************
type TFieldTypeToBDEField = record
        fType,
        fSubType : word;
    end;

function FieldTypeToBDEField(FieldType: TFieldType): TFieldTypeToBDEField;
begin
  Result.fType      := fldUNKNOWN;
  Result.fSubType   := 0;
  with result do
  begin
      case FieldType of
        ftString      :  fType := fldZSTRING;
        ftSmallint    :  fType := fldINT16;
        ftInteger     :  fType := fldINT32;
        ftWord        :  fType := fldUINT16;
        ftBoolean     :  fType := fldBOOL;
        ftFloat       :  fType := fldFLOAT;
        ftBCD         :  fType := fldBCD;
        ftDate        :  fType := fldDATE;
        ftTime        :  fType := fldTIME;
        ftDateTime    :  fType := fldTIMESTAMP; // no fldDATETIME;
        ftBytes       :  fType := fldBYTES;
        ftVarBytes    :  fType := fldVARBYTES;
        ftCursor      :  fType := fldCURSOR;
        ftWideString  :  fType := fldZSTRING;
        ftLargeInt    :  fType := fldINT64;
        ftADT         :  fType := fldADT;
        ftArray       :  fType := fldARRAY;
        ftReference   :  fType := fldREF;
        ftVariant     :  fType := fldUNKNOWN;

        ftCurrency    :  begin fType := fldFLOAT;       fSubType := fldstMONEY;end;
        ftAutoInc     :  begin fType := fldINT32;       fSubType := fldstAUTOINC;end;
        ftMemo        :  begin fType := fldBLOB;        fSubType := fldstMEMO;end;
        ftBlob        :  begin fType := fldBLOB;        fSubType := fldstBINARY;end;
        ftGraphic     :  begin fType := fldBLOB;        fSubType := fldstGRAPHIC;end;
        ftFmtMemo     :  begin fType := fldBLOB;        fSubType := fldstFMTMEMO;end;
        ftParadoxOle  :  begin fType := fldBLOB;        fSubType := fldstDBSOLEOBJ;end;
        ftTypedBinary :  begin fType := fldBLOB;        fSubType := fldstTYPEDBINARY;end;
        ftFixedChar   :  begin fType := fldZSTRING;     fSubType := fldstFIXED;end;
      end;
  end;
end;

function openORcreateTable(T: TTable; L: TLabel; Bar : TGauge): boolean; overload;
var
    j, nFields      : integer;
    defInd          : TIndexDefs;
    curIndex        : string;
    notExists       : boolean;

    procedure RestructureTable;
    type
        TFieldArray = Array[0..10000] of FLDDesc;
        PFieldArray = ^TFieldArray;
    var cbDataBuff      : CBPROGRESSDesc;
        dirP            : DBITBLNAME;
        hDb             : hDbiDb;
        TblDesc         : CRTblDesc;
        CProps          : CURProps;
        pOldFields,
        pNewFields      : pFLDDesc;
        pOldFieldArray,
        pNewFieldArray  : PFieldArray;
        pOpType,pOpType0: pCROpType;
        bdec            : TBDECallback;
        i               : Integer;
        oldTable        : TTable;
        tField          : TFieldTypeToBDEField;
        fieldsModified  : boolean;
        fieldsAdded     : boolean;
        fieldsDroped    : boolean;

        function oldFieldFound : integer;
        var j : integer;
        begin
            result := -1;
            for j := 0 to T.Fields.Count - 1 do begin
                if compareText(pOldFieldArray^[i-1].szName,T.Fields[j].fieldName) = 0
                then begin
                        result := j;
                        break;
                end;
            end;
        end;
        function FieldExistsOnOldTable : boolean;
        var j : integer;
        begin
            result := FALSE;
            for j := 0 to TblDesc.iFldCount-1 do begin
                if compareText(pNewFieldArray^[j].szName,T.fields[i].FieldName) = 0
                then begin
                    result := TRUE;
                    break;
                end;
            end;
        end;
    begin
        // Table must not used by other user
        fieldsModified  := FALSE;
        fieldsAdded     := FALSE;
        fieldsDroped    := FALSE;
        bdec            := NIL;
        oldTable := TTable.Create(nil);
        oldTable.DatabaseName := T.DatabaseName;
        oldTable.TableName := T.TableName;
        oldTable.Open;
        Check(DbiGetDirectory(oldTable.DBHandle, False, dirP));
        Check(DbiGetCursorProps(oldTable.Handle, CProps));
        nFields := CProps.iFields;
        if nFields < T.Fields.Count
        then nFields := T.Fields.Count; // enough to hold all fDescs

        pOldFields      := allocMem(nFields * sizeof(FLDDesc));
        pOldFieldArray  := PFieldArray(pointer(pOldFields));
        Check(DbiGetFieldDescs(oldTable.Handle, pOldFields));
        pNewFields      := allocMem(nFields * sizeof(FLDDesc));

        pNewFieldArray  := PFieldArray(pointer(pNewFields));
        pOpType         := allocMem(nFields * sizeof(CROpType));
        pOpType0        := pOpType;
        try

            FillChar(TblDesc, sizeof(CRTblDesc), #0);
            StrPCopy(TblDesc.szTblName, oldTable.TableName);
            StrCopy(TblDesc.szTblType, CProps.szTableType);
            TblDesc.iFldCount := 0;
            FillChar(pOpType^, nFields * sizeof(CROpType), crNOOP);

            for i := 1 to CProps.iFields do begin
                pOldFieldArray^[i-1].iFldNum := i; // MUST BE REASSIGNED
                j := oldFieldFound; // j = field.index (0...)
                if j > -1 // if field remains... add it to TblDesc
                then with pNewFieldArray^[TblDesc.iFldCount] do begin
                    pNewFieldArray^[TblDesc.iFldCount] := pOldFieldArray^[i-1];
                    tField := FieldTypeToBDEField(T.Fields[j].DataType);
                    if (iFldType <> tField.fType)
                    or (iSubType <> tField.fSubType)
                    then begin
                        iFldType        := tField.fType;
                        iSubType        := tField.fSubType;
                        fieldsModified  := TRUE;
                        pOpType^        := crMODIFY;
                    end;
                    if  (iUnits1  <> T.Fields[j].Size)
                    and (T.Fields[j].Size > 0) // stadard types have size = 0
                    then begin
                        iUnits1         := T.Fields[j].Size;
                        fieldsModified  := TRUE;
                        pOpType^        := crMODIFY;
                    end;
                    Inc(TblDesc.iFldCount);
                    inc(pOpType,1);
                end
                else fieldsDroped := TRUE; // else drop it
            end;
            // now add new fields
            for i := 0 to T.Fields.Count-1 do
            if  (T.fields[i].FieldKind = fkData)
            and (not FieldExistsOnOldTable) then // if field is new then add it to TblDesc
            with pNewFieldArray^[TblDesc.iFldCount] do begin
                StrCopy(szName, pANSIchar(AnsiString(T.fields[i].FieldName)));
                tField      := FieldTypeToBDEField(T.Fields[i].DataType);
                iFldNum     := TblDesc.iFldCount + 1;
                iFldType    := tField.fType;
                iSubType    := tField.fSubType;
                iUnits1     := T.Fields[i].Size;
                pOpType^    := crADD;
                Inc(TblDesc.iFldCount);
                inc(pOpType,1);
                fieldsAdded := TRUE;
            end;
            pOpType := pOpType0;            
            TblDesc.pecrFldOp   := pOpType;
            TblDesc.pfldDesc    := pNewFields;
            TblDesc.bPack       := TRUE;
            nRecords := oldTable.RecordCount;
            oldTable.Close;
            if fieldsModified
            or fieldsAdded
            or fieldsDroped then begin
                if Bar <> nil
                then begin
                    Bar.Visible := TRUE;
                    Bar.Progress := 0;
                    QuickProgress := Bar;
                end;
                Check(DbiOpenDatabase(nil, nil, dbiReadWrite, dbiOpenExcl, nil, 0,nil, nil, hDb));
                Check(DbiSetDirectory(hDb, Dirp));
                bdec := TBDECallback.Create(nil,oldTable.Handle,cbGENPROGRESS,@cbDataBuff, SizeOf(cbDataBuff),fooClass.ProgressCallback,TRUE);
                Check(DbiDoRestructure(hDb, 1, @TblDesc, nil {or a new TableName}, nil, nil, FALSE));
            end;
        finally
            FreeMem(pOldFields, CProps.iFields * sizeof(FLDDesc));
            FreeMem(pNewFields, T.Fields.Count * sizeof(FLDDesc));
            FreeMem(pOpType,    T.Fields.Count * sizeof(CROpType));
            oldTable.Free;
            if assigned(bdec)
            then bdec.Free;
        end;
    end;
    procedure reIndex(indexNo : integer); // creats the specified index
    begin
        T.Close;
        with defInd[indexNo] do
        T.AddIndex(Name, Fields,Options);
    end;

    procedure checkAllIndexes; // check all secondary indexes
    var
        i   : integer;
    begin
        with T do
        for i := 0 to defInd.Count - 1 do
        if not (ixPrimary in defInd[i].Options)
        then try
            T.indexName := defInd[i].name;
            T.Open;
        except // if fails --> recreate it
            reIndex(i);
        end;
    end;
begin
    result := TRUE;
    if T.active then exit; // not needs checking if allready opened

    forceDirectories(T.databaseName);
    try
        notExists := not T.Exists;
    except
        {on E: EDBEngineError do begin
            messageBox(application.handle,
                pchar('Problem with table ' + T.TableName + #13#13 + E.Errors[0].Message +
                    '   (' + IntToStr(E.Errors[0].ErrorCode) + ')'#13), '',
                MB_ICONWARNING or MB_OK or MB_TOPMOST);}
        result := FALSE;
        exit;
    end;
    if notExists then begin
        T.CreateTable;
        if not T.Exists then begin
            messageBox(application.handle,
                'The table '+ T.TableName + ' cannot be created  !', '',
                MB_ICONWARNING or MB_OK or MB_TOPMOST);
            result := FALSE;
            exit;
        end;
        T.open;
        exit; // not needs checking when just created
    end;
    if assigned(L) then begin
        L.caption := 'checking table : ' + T.TableName;
        L.visible := TRUE;
        application.processMessages;
    end;
    curIndex    := T.indexName;
    T.indexName := ''; // open table without indexing to check structure
    try
        RestructureTable; // firstly check fields (add/delete/modify)
        defInd := TIndexDefs.Create(T);
        defInd.Assign(T.IndexDefs);
        T.indexName := curIndex; // firstly check predefined + primary index
        try                      // to check primary index
            T.open; // if opens without error then primary index is ok
        except // if fails, primary index must be recreated
            reIndex(0);
        end;

        checkAllIndexes; // primary index is ok so check the rest
        T.indexName := curIndex; // all indexes are ok so open curIndex
        if not T.active then T.open; // if closed in checkIndexes
    except
        // here comes if :
           // 0. the table on disk cannot open
           // 1. cannot restructure the Table
           // 2. the table on disk is corrupted
           // 3. cannot recreate the indexs
        on E: EDBEngineError do begin
            messageBox(application.handle,
                pchar('Problem with table ' + T.TableName + #13#13 + E.Errors[0].Message +
                    '   (' + IntToStr(E.Errors[0].ErrorCode) + ')'#13), '',
                MB_ICONWARNING or MB_OK or MB_TOPMOST);
            result := FALSE;
        end;
    end;
    defInd.Free;
    if L <> nil
    then L.visible := FALSE;
    if Bar <> nil
    then Bar.Visible := FALSE;
    application.ProcessMessages;
end;

end.

Answer 2

This is some code which adds one or more fields to a TTable. On completion, the values in the original fields of the table are correctly displayed in a DBGrid. Other necessary routines are set out below.

To use the code, please create a new project and add a TTable, TDataSource and a TDBGrid connected up in the usual way and also a TButton to its main form.

procedure AddFields(Table : TTable; FieldsToAdd : TChangeRecs);
{  this code is based on the Delphi example code in the BDE32 help file,
   extensively revised
}
var
  Props: CURProps;
  hDb: hDBIDb;
  TableDesc: CRTblDesc;,
  pOldFields,
  pNewFields,
  pCurField: pFLDDesc;
  pOp, pCurOp: pCROpType;
  ItrFld: Word;
  i,
  j : Integer;
  POldFieldDescArray,
  PNewFieldDescArray : PFieldDescArray;
  OldFieldDescArraySize,
  NewFieldDescArraySize : Integer;
  FieldsToAddCount : Integer;
  NewFieldsCount : Integer;
begin
  // Initialize the pointers...
  pOldFields := nil;
  pNewFields := Nil;
  pOp := nil;

  CheckTableType(Table, Props);

  try

    FieldsToAddCount := Length(FieldsToAdd);
    OldFieldDescArraySize := Props.iFields * sizeof(FLDDesc);
    NewFieldDescArraySize := OldFieldDescArraySize + (FieldsToAddCount * sizeof(FLDDesc));

    pOldFields := AllocMem(OldFieldDescArraySize);
    pNewFields := AllocMem(NewFieldDescArraySize);

    // Allocate memory for the operation descriptor...
    NewFieldsCount := Props.iFields + FieldsToAddCount;
    pOp := AllocMem((NewFieldsCount) * sizeof(CROpType));
    // Null out the operations (= crNOOP)...
    FillChar(pOp^, NewFieldsCount * sizeof(CROpType), #0);

    for i := Props.iFields to Props.iFields + FieldsToAddCount do begin
       pCurOp := pOp;
       Inc(pCurOp, i);
       pCurOp^ := crAdd;
    end;

    // Fill field descriptor with the existing field information...
    Check(DbiGetFieldDescs(Table.Handle, pOldFields));

    POldFieldDescArray := PFieldDescArray(pointer(pOldFields));
    PNewFieldDescArray := PFieldDescArray(pointer(pNewFields));

    //  copy existing fields into pNewFields
    for i := 0 to Table.FieldCount - 1 do begin
      pNewFieldDescArray^[i] := pOldFieldDescArray^[i];
    end;

    //  and add the new fields
    for i := 0 to  FieldsToAddCount - 1 do begin
      pCurField := pNewFields;
      Inc(pCurField, Table.FieldCount + i); // +1 to account for old fields
      pCurField^.iFldNum := Table.FieldCount + i;
      pCurField^.szName := FieldsToAdd[i].szName;
      pCurField^.iFldType := FieldsToAdd[i].iType; //FieldTypeToBDEFieldInt(TFieldType(FieldsToAdd[i].iType));
      pCurField^.iUnits1 := FieldsToAdd[i].iLength;
      // Note: Other fields' ChangeRec properties not set
    end;

    FillChar(TableDesc, sizeof(TableDesc), #0);
    hDb := Table.DBHandle;
    StrPCopy(TableDesc.szTblName, Table.TableName);
    StrCopy(TableDesc.szTblType, Props.szTableType);

    // Set the new field count for the table
    TableDesc.iFldCount := Props.iFields + FieldsToAddCount;
    TableDesc.pecrFldOp := pOp;
    TableDesc.pFldDesc := pNewFields;
    Table.Close;
    Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False));

    //  Clear the table's previous FieldDefs and Fields
    Table.FieldDefs.Clear;
    Table.Fields.Clear;

  finally
    if (pOldFields <> nil) then
      FreeMem(pOldFields);
    if (pNewFields <> nil) then
      FreeMem(pNewFields);
    if (pOp <> nil) then
      FreeMem(pOp);
  end;
end;

Note that I've written this code without relying on the PointerMath directive available in modern versions of Delphi and I've tested it on Delphi 10.4.2 and Delphi 7. The code is deliberately more long-winded than it strictly needs to be - it avoids Move operations for example - as my main concern was to ensure that it was as easy to trace in the debugger as possible. It is for that reason also that I've used two separate sets of field descriptors, pOldFields^ and pNewFields rather than one, as the BDE32 Help examples and various code examples derived from it do.

The problem reported by the OP in the q and an earlier one of his, namely that the field values of the original fields display blank in the DBGrid is because the field values are actually Null, so there is nothing to display. A necessary requirement to avoid this is that a) the field operation array (pointed to by pOp^) is large enough to have one row for each field in the table, including the one(s) being added and that the field operation code is set to crNoOp for the existing fields and crAdd for the new ones. Another requirement is that the pointers to the field descriptors are correctly set, which is why my pointer code is so long-winded.

The reason for the declarations of POldFieldDescArray and PNewFieldDescArray, and the fact that they are declared as pointers to an Array[0..1000] of FLDDesc is purely to assist observation of the individual field descriptors (pFldDesc^) in the debugger.

My answer https://stackoverflow.com/a/66762667/2663863 to the OP's previous q dealt specifically with dropping a single field from the table. However, it is readily adaptable to deleting several fields at once using techniques similar to those in the above AddField.

function FieldTypeToBDEFieldInt(FieldType: TFieldType): Word;
{ This code may have originated with a Nathaniel Woolls, author of TFieldUpdate v1.1 }
begin
  Result := fldUNKNOWN;
  case FieldType of
    ftUnknown     :  result := fldUNKNOWN;
    ftString      :  result := fldZSTRING;
    ftSmallint    :  result := fldPDXSHORT;
    ftInteger     :  result := fldInt32;
    ftWord        :  result := fldUINT16;
    ftBoolean     :  result := fldBOOL;
    ftFloat       :  result := fldFLOAT;
    ftCurrency    :  result := fldPDXMONEY;
    ftBCD         :  result := fldBCD;
    ftDate        :  result := fldDATE;
    ftTime        :  result := fldTIME;
    ftDateTime    :  result := fldPDXDATETIME;
    ftBytes       :  result := fldBYTES;
    ftVarBytes    :  result := fldVARBYTES;
    ftAutoInc     :  result := fldPDXAUTOINC;
    ftBlob        :  result := fldPDXBINARYBLOB; //fldBLOB;
    ftMemo        :  result := fldPDXMEMO;
    ftGraphic     :  result := fldPDXGRAPHIC;
    ftFmtMemo     :  result := fldPDXFMTMEMO;
    ftParadoxOle  :  result := fldPDXOLEBLOB;
    ftTypedBinary :  result := fldPDXBINARYBLOB;
    ftCursor      :  result := fldCURSOR;
    ftFixedChar   :  result := fldPDXCHAR;
    ftWideString  :  result := fldZSTRING;
    ftLargeInt    :  result := fldINT32;
    ftADT         :  result := fldADT;
    ftArray       :  result := fldARRAY;
    ftReference   :  result := fldREF;
    ftVariant     :  result := fldUNKNOWN;
  end;
end;


type

  TFieldArray = Array of TField;

  TFieldDescArray = Array[0..1000] of FLDDesc;
  PFieldDescArray = ^TFieldDescArray;

  TChangeRec = packed record
    szName: DBINAME;
    iType: Word;
    iSubType: Word;
    iLength: Word;
    iPrecision: Byte;
  end;
  PChangeRec = ^TChangeRec;

  TChangeRecs = Array of TChangeRec;

procedure TForm1.CreateTable(T : TTable);
var
  AField : TField;
begin
  AField := TIntegerField.Create(T);
  AField.FieldName := 'Field1';
  AField.DataSet := T;

  AField := TStringField.Create(T);
  AField.FieldName := 'Field2';
  AField.DataSet := T;
  AField.Size := 20;

  T.Exclusive := True;

  T.CreateTable;
  T.Open;

  T.InsertRecord([1, 'r1f2']);
  T.InsertRecord([2, 'r2f2']);
  T.InsertRecord([3, 'r3f2']);

end;

procedure TForm1.TestAddFields;
var
  FieldsToAdd : TChangeRecs;
begin
  CreateTable(Table1);
  if not Table1.Active then
    Table1.Open;
  try
  //  Define fields to be added
    SetLength(FieldsToAdd,2);

    FieldsToAdd[0].szName := 'Added1';
    FieldsToAdd[0].iType := FieldTypeToBDEFieldInt(ftString);
    FieldsToAdd[0].iLength := 8;

    FieldsToAdd[1].szName := 'Added2';
    FieldsToAdd[1].iType := FieldTypeToBDEFieldInt(ftInteger);

    AddFields(Table1, FieldsToAdd);
  finally
    FieldsToAdd := Nil;
  end;

  if not Table1.Active then
    Table1.Open;

end;

procedure TForm1.btnRestructureClick(Sender: TObject);
begin
  TestAddFields;
end;