|
Впрочем, ако правилно те разбирам (а ти се изказваш направилно) искаш да си добавиш поле към физическата таблица на диска - сорса долу е по тоя въпрос.
Но все пак, ако искаш да си променяш полетата в ТТабле - разгледай tFieldsDef пропъртито и как от него се прави tFields.
Събирал съм и съм дописвал, отдавна не е проверявано, но работи в няколко проекта на много места из страната.
unit UtilsTablesRestructure;
interface
uses
SysUtils, Bde, {BdeUtils,} DBTables, DB, DbiProcs, DbiErrs, DbiTypes;
type TChangeRec = packed record
szName: DBINAME;
iType: word;
iSubType: word;
iLength: word;
iPrecision: byte;
end;
// Функции добавящи полета посредтсвом DbiDoRestructure
{ http://delphi.vitpc.com/asp/answer.asp?IDAnswer=6786
На основе "Секретов по Дельфи от Валентина Озерова" сделал такой юнит:{}
{ procedure TForm1.Button5Click(Sender: TObject);
var
Table1: tTable;
begin
Table1 := TableOpen_ByFilePath(Self,ExePath+'sa_vB3.db');
Table_CheckAndFieldString(Table1,'Proba',12);
end;
{}function BDEStringFieldResize(ATable: TTable; AFieldName: string; ANewSize: integer): boolean;
{}procedure AddFieldToTable(Table: TTable; NewField: TChangeRec);
{}function Table_CheckAndFieldString(aTable: TTable; const aFieldName: string; aSize: integer): boolean;
// Функции добавящи полета посредтсвом SQL
{ procedure TForm1.ButtonXXXClick(Sender: TObject);
begin
CreateField(ExePath+'\sa_vB3.db',
'"FieldSInt1 INTEGER","FieldSInt2 SMALLINT","FieldSInt3 SMALLINT","FieldSInt4 SMALLINT"');
end;
{}function CreateField(aTable: tTable; const aFieldNames_And_Type: string): integer; overload;
{}function CreateField(const aPathTable, aFieldNames_And_Type: string): integer; overload;
implementation
uses
Classes,
Dialogs,
UtilsTables;
{}function CreateField(aTable: tTable; const aFieldNames_And_Type: string): integer;
var
xRecNo : integer;
begin
Result:=2;
if aTable<>nil then begin
xRecNo := -2;
with aTable do begin
try
if Active then begin
xRecNo := RecNo;
Active := false;
end;{}
Result:=CreateField( Table_GetPath(aTable),aFieldNames_And_Type);
finally
if xRecNo>=0 then begin
Active := true;
RecNo := xRecNo;
end;
end;
end;
end;
end;
{}function CreateField(const aPathTable, aFieldNames_And_Type: string): integer;
var
xQuery : tQuery;
StrList : tStringList;
i : integer;
s : string;
begin
Result:=1;
if aPathTable<>'' then begin
StrList:=tStringList.Create;
try
StrList.CommaText:=aFieldNames_And_Type;
if StrList.Count>0 then begin
xQuery := TQuery.Create(nil);
try
// xQuery.DataBaseName := 'asd';
xQuery.SQL.Add('ALTER TABLE "'+aPathTable+'"');
i:=0;
while i<StrList.Count do begin
s:='ADD '+StrList.Strings;
inc(i);
if i<StrList.Count then begin
s:=s+',';
end;
xQuery.SQL.Add(s);
end;
xQuery.ExecSQL;
Result:=0;
finally
FreeAndNil(xQuery);
end;
end;
finally
FreeAndNil(StrList);
end;
end;
end;
{}function BDEStringFieldResize(ATable: TTable; AFieldName: string; ANewSize: integer): boolean;
type
TRestructStatus = (rsFieldNotFound, rsNothingToDo, rsDoIt);
var
hDB: hDBIdb;
pTableDesc: pCRTblDesc;
pFldOp: pCROpType; {фактически это массив array of pCROpType}
pFieldDesc: pFldDesc; {фактически это массив array of pFldDesc}
CurPrp: CurProps;
// CSubType: integer;
// CCbrOption: CBRType;
eRestrStatus: TRestructStatus;
// pErrMess: DBIMsg;
i: integer;
begin
Result := False;
eRestrStatus := rsFieldNotFound;
AFieldName := AnsiUpperCase(AFieldName);
pTableDesc := nil;
pFieldDesc := nil;
pFldOp := nil;
with ATable do begin
try
{убедимся что имеем исключительный доступ и сохраним dbhandle:}
if Active and (not Exclusive) then Close;
if (not Exclusive) then Exclusive := True;
if (not Active) then Open;
hDB := DBHandle;
{готовим данные для DBIDoRestructure:}
Check(DBIGetCursorProps(Handle,CurPrp));
GetMem(pFieldDesc,CurPrp.iFields*sizeOf(FldDesc));
Check(DBIGetFieldDescs(Handle,pFieldDesc));
GetMem(pFldOp,CurPrp.iFields*sizeOf(CROpType));
FillChar(pFldOp^,CurPrp.iFields*sizeOf(CROpType),0);
{ищем в цикле (через fielddesc) наше поле:}
for i:=1 to CurPrp.iFields do
begin
{для ввода мы имеем серийные номера вместо
Pdox ID, возвращаемых DbiGetFieldDescs:}
pFieldDesc^.iFldNum := i;
if (AnsiUppercase(StrPas(pFieldDesc^.szName)) = AFieldName)
and (pFieldDesc^.iFldType = fldZSTRING) then
begin
eRestrStatus := rsNothingToDo;
if (pFieldDesc^.iUnits1 <> ANewSize) then
begin
pFieldDesc^.iUnits1 := ANewSize;
pFldOp^ := crModify;
eRestrStatus := rsDoIt;
end;
end;
inc(pFieldDesc);
inc(pFldOp);
end; {for}
{"регулируем" массив указателей:}
dec(pFieldDesc,CurPrp.iFields);
dec(pFldOp,CurPrp.iFields);
{в случае отсутствия операций возбуждаем исключение:}
case eRestrStatus of
//rsNothingToDo: raise Exception.Create('Ничего не сделано');
rsNothingToDo:
begin
Result := True;
Exit;
end;
rsFieldNotFound: raise Exception.Create('Поле не найдено');
end;
GetMem(pTableDesc,sizeOf(CRTblDesc));
FillChar(pTableDesc^,SizeOf(CRTblDesc),0);
StrPCopy(pTableDesc^.szTblName,TableName);
{StrPCopy(pTableDesc^.szTblType,szPARADOX); {}
pTableDesc^.szTblType := CurPrp.szTableType;
pTableDesc^.iFldCount := CurPrp.iFields;
pTableDesc^.pecrFldOp := pFldOp;
pTableDesc^.pfldDesc := pFieldDesc;
Close;
Check( DbiDoRestructure(hDB, 1, pTableDesc, nil, nil, nil, False) );
finally
if pTableDesc<>nil then
FreeMem(pTableDesc,sizeOf(CRTblDesc));
if pFldOp<>nil then
FreeMem(pFldOp,CurPrp.iFields*sizeOf(CROpType));
if pFieldDesc<>nil then
FreeMem(pFieldDesc,CurPrp.iFields*sizeOf(FldDesc));
Open;
Close;
end; {пробуем с table1}
end;
Result := True;
end;
/////
//This example will add a field to the end of an existing table.
//NOTE: You must fill in all options in the ChangeRec with 0 or "" if the option
// is not used in the restructure. FillChar can be used to do this:
//Fillchar(MyChangeRec, sizeof(MyChangeRec), 0);
//This example uses the following input:
//AddField(Table1, MyChangeRec);
//TChangeRec is defind as follows:
//TChangeRec = packed record
// szName: DBINAME;
// iType: word; //См BDE.INT
// iSubType: word;
// iLength: word;
// iPrecision: byte;
// end;
// The function is defined as follows:
{}procedure AddFieldToTable(Table: TTable; NewField: TChangeRec);
var
Props: CURProps;
hDb: hDBIDb;
TableDesc: CRTblDesc;
pFlds: pFLDDesc;
pOp: pCROpType;
B: byte;
begin
// Make sure the table is open exclusively so we can get the db handle...
if Table.Active = False then
raise EDatabaseError.Create('Таблица должна быть открыта для реструктуризации!');
if Table.Exclusive = False then
raise EDatabaseError.Create('Таблица должна быть открыта для реструктуризации в монопольном режиме!');
// Get the table properties to determine table type...
Check(DbiSetProp(hDBIObj(Table.Handle), curxltMODE, integer(xltNONE)));
Check(DbiGetCursorProps(Table.Handle, Props));
pFlds := AllocMem((Table.FieldCount + 1) * sizeof(FLDDesc));
FillChar(pFlds^, (Table.FieldCount + 1) * sizeof(FLDDesc), 0);
Check(DbiGetFieldDescs(Table.handle, pFlds));
for B := 1 to Table.FieldCount do begin
pFlds^.iFldNum := B;
Inc(pFlds, 1);
end;
try
StrCopy(pFlds^.szName, NewField.szName);
pFlds^.iFldType := NewField.iType;
pFlds^.iSubType := NewField.iSubType;
pFlds^.iUnits1 := NewField.iLength;
pFlds^.iUnits2 := NewField.iPrecision;
pFlds^.iFldNum := Table.FieldCount + 1;
finally
Dec(pFlds, Table.FieldCount);
end;
pOp := AllocMem((Table.FieldCount + 1) * sizeof(CROpType));
Inc(pOp, Table.FieldCount);
pOp^ := crADD;
Dec(pOp, Table.FieldCount);
// Blank out the structure...
FillChar(TableDesc, sizeof(TableDesc), 0);
// Get the database handle from the table"s cursor handle...
Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));
// Put the table name in the table descriptor...
StrPCopy(TableDesc.szTblName, Table.TableName);
// Put the table type in the table descriptor...
StrPCopy(TableDesc.szTblType, Props.szTableType);
// Close the table so the restructure can complete...
TableDesc.iFldCount := Table.FieldCount + 1;
Tabledesc.pfldDesc := pFlds;
TableDesc.pecrFldOp := pOp;
Table.Close;
// Call DbiDoRestructure...
try
Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, FALSE));
finally
FreeMem(pFlds);
FreeMem(pOp);
Table.Open;
end;
end;
{}function Table_CheckAndFieldString(aTable: TTable; const aFieldName: string; aSize: integer): boolean;
var
MyChangeRec : TChangeRec;
begin
Result := false;
aTable.FieldDefs.Update;
if aTable.FieldDefs.IndexOf(aFieldName) < 0 then begin
//messageDlg('нету поля KPP!',mtWarning,[mbOK],0);
{ ...
Делаю резервную копию изменяемой таблицы
...{}
try
aTable.Close;
aTable.Exclusive := True;
aTable.Open;
Fillchar(MyChangeRec, sizeof(MyChangeRec), 0);
// MyChangeRec.szName := pChar(aFieldName);
// StrCopy(MyChangeRec.szName, pChar(aFieldName));
StrPCopy(MyChangeRec.szName, aFieldName);
MyChangeRec.iType := fldPDXCHAR; //PDX A 9
MyChangeRec.iLength := aSize;
AddFieldToTable(aTable, MyChangeRec);
Result := true;
except
on E: Exception do begin
MessageDlg('Ошибка обновления базы '+aTable.TableName+#13+
E.Message+#13+' Сообщите текст ошибки разработчику!',
mtError,
[mbOK],
0);
end
end;
end else begin
Result := true; // За сега не проверявам дали размерът на новото поле съответства на старото поле
end;
end;
end.
Редактирано от NikB на 05.01.07 23:15.
|
Събирал съм и съм дописвал [re: Учeниka]
