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.
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 natew@mobiletoys.com
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.