Delphi10.4如何使用BDE dbiDoRestructure添加字段？
How to use BDE dbiDoRestructure to add fields in Delphi 10.4?
我正在尝试使用 BDE.dbiDoRestructure 创建一个函数来添加/删除/修改 Paradox Tables 的字段（请参阅我的其他问题 ），但是当我得到Table 正确重组并且网格显示正确的数据行数，其所有数据单元格都是空的。
这是一段向 TTable 添加一个或多个字段的代码。完成后，table 的原始字段中的值将正确显示在 DBGrid 中。其他必要的例程如下。
要使用该代码，请创建一个新项目并添加一个 TTable、TDataSource 和一个以通常方式连接的 TDBGrid 以及一个 TButton 到其主窗体。
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;
请注意，我在不依赖 PointerMath 指令的情况下编写了这段代码
在 Delphi 的现代版本中可用，我已经在 Delphi 10.4.2 和
Delphi 7. 代码故意比实际需要的更冗长 - 例如它避免了 Move 操作 - 因为我主要关心的是确保它在调试器中很容易跟踪尽可能。也是出于这个原因，我使用了两组不同的字段描述符，pOldFields^ 和 pNewFields，而不是像 BDE32 帮助示例和从中派生的各种代码示例那样使用一组。
OP在q和他的一个更早的问题中报告的问题，即原始字段的字段值在DBGrid中显示为空白是因为字段值实际上是Null，所以没有任何显示.避免这种情况的一个必要条件是 a) 字段操作数组（由 pOp^ 指向）足够大以在 table 中的每个字段都有一行，包括正在添加的一个或多个现有字段的字段操作代码设置为 crNoOp，新字段的字段操作代码设置为 crAdd。另一个要求是正确设置指向字段描述符的指针，这就是为什么我的指针代码如此冗长。
声明 POldFieldDescArray 和 PNewFieldDescArray 的原因，以及它们是
声明为指向 Array[0..1000] of FLDDesc 的指针纯粹是为了帮助观察调试器中的各个字段描述符 (pFldDesc^)。
我对 OP 上一个问题的回答 专门处理从 table 中删除一个字段。但是，使用类似于上述 AddField.
中的技术，很容易适应table 一次删除多个字段
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;
这是我构建的单元（Delphi 10.4，Win 10/64），用于测试和重建 BDE TTable（Paradox、DB、FOXpro）。
它能够打开/创建、检查和重建 table（字段和索引）并可视化进度。
您可以自由使用/改进它。
{
based on
http://www.delphigroups.info/2/5a/37309.html
and TFieldUpdate v1.1 by Nathanial Woolls natew@mobiletoys.com
and MartynA suggestions
at
}
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.
我正在尝试使用 BDE.dbiDoRestructure 创建一个函数来添加/删除/修改 Paradox Tables 的字段（请参阅我的其他问题
这是一段向 TTable 添加一个或多个字段的代码。完成后，table 的原始字段中的值将正确显示在 DBGrid 中。其他必要的例程如下。
要使用该代码，请创建一个新项目并添加一个 TTable、TDataSource 和一个以通常方式连接的 TDBGrid 以及一个 TButton 到其主窗体。
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;
请注意，我在不依赖 PointerMath 指令的情况下编写了这段代码
在 Delphi 的现代版本中可用，我已经在 Delphi 10.4.2 和
Delphi 7. 代码故意比实际需要的更冗长 - 例如它避免了 Move 操作 - 因为我主要关心的是确保它在调试器中很容易跟踪尽可能。也是出于这个原因，我使用了两组不同的字段描述符，pOldFields^ 和 pNewFields，而不是像 BDE32 帮助示例和从中派生的各种代码示例那样使用一组。
OP在q和他的一个更早的问题中报告的问题，即原始字段的字段值在DBGrid中显示为空白是因为字段值实际上是Null，所以没有任何显示.避免这种情况的一个必要条件是 a) 字段操作数组（由 pOp^ 指向）足够大以在 table 中的每个字段都有一行，包括正在添加的一个或多个现有字段的字段操作代码设置为 crNoOp，新字段的字段操作代码设置为 crAdd。另一个要求是正确设置指向字段描述符的指针，这就是为什么我的指针代码如此冗长。
声明 POldFieldDescArray 和 PNewFieldDescArray 的原因，以及它们是
声明为指向 Array[0..1000] of FLDDesc 的指针纯粹是为了帮助观察调试器中的各个字段描述符 (pFldDesc^)。
我对 OP 上一个问题的回答 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;
这是我构建的单元（Delphi 10.4，Win 10/64），用于测试和重建 BDE TTable（Paradox、DB、FOXpro）。 它能够打开/创建、检查和重建 table（字段和索引）并可视化进度。 您可以自由使用/改进它。
{
based on
http://www.delphigroups.info/2/5a/37309.html
and TFieldUpdate v1.1 by Nathanial Woolls natew@mobiletoys.com
and MartynA suggestions
at
}
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.