Field Restructuring made easy!
Brett W. Fleming
help in restructuring fields in paradox tables. It has the capability of adding,
deleting, and modifying fields and only needs to make one call to
DBIDoRestructure. Since the unit is not very long I have attached it here. If
you like this code, please let me know. If you improve this code, please let me
have a copy.
unit Restructure;
{
Freeware by Brett W. Fleming 1999
brettf...@metalcode.com
}
interface
uses
BDE, DbTables;
type
TTableRestructure = class(TObject)
constructor Create;
destructor Destroy; override;
protected
Fields: PFLDDesc;
Operations: PCROpType;
LocalFieldCount: Integer;
procedure DestroyFieldDescriptors;
private
function GetField(Index: Integer): PFLDDesc;
function GetFieldLength(Index: Integer): Word;
function GetFieldName(Index: Integer): String;
function GetFieldType(Index: Integer): Word;
function GetFieldUnits(Index: Integer): Word;
function GetOperation(Index: Integer): PCROpType;
procedure SetFieldLength(Index: Integer; const Value: Word);
procedure SetFieldType(Index: Integer; const Value: Word);
procedure SetFieldUnits(Index: Integer; const Value: Word);
procedure SetFieldName(Index: Integer; const Value: String);
procedure DetailError(ErrorCode: DbiResult);
public
function AddField: Integer;
function DeleteField(Index: Integer): Boolean;
function FindField(Name: String): Integer;
procedure LoadTableStructure(Table: TTable);
procedure SaveTableStructure(Table: TTable);
procedure PrintStructure;
property FieldCount: Integer read LocalFieldCount;
property FieldLength[Index: Integer]: Word read GetFieldLength write
SetFieldLength;
property FieldName[Index: Integer]: String read GetFieldName write
SetFieldName;
property FieldType[Index: Integer]: Word read GetFieldType write SetFieldType;
property FieldUnits[Index: Integer]: Word read GetFieldUnits write
SetFieldUnits;
property Field[Index: Integer]: PFLDDesc read GetField;
property Operation[Index: Integer]: pCROpType read GetOperation;
end;
implementation
uses
SysUtils, Dialogs;
{ TTableRestructure }
//
// Purpose: To add a new field to the table
//
// Parameters: None
//
// Effects: A new blank field descriptor is created and added to the internal
// list of Field Descriptors which is reallocated to accomodate the new field
//
// Returns: Index of the new field in the array, or -1 if the operation failed
//
function TTableRestructure.AddField: Integer;
var
NewField: PFLDDesc;
NewOperation: pCROpType;
begin
Result := -1;
if (Fields <> nil) then begin
ReallocMem(Fields, (LocalFieldCount + 1) * SizeOf(FLDDesc));
ReallocMem(Operations, (LocalFieldCount + 1) * SizeOf(CROpType));
//Move to the new field and empty it out
NewField := Fields;
Inc(NewField, LocalFieldCount);
FillChar(NewField^, SizeOf(FLDDesc), 0);
NewField^.iFldNum := LocalFieldCount + 1;
//Move to the new operation and set it to add
NewOperation := Operations;
Inc(NewOperation, LocalFieldCount);
NewOperation^ := crAdd;
Inc(LocalFieldCount);
//Return the new fields index
Result := LocalFieldCount - 1;
end;
end;
//
// Purpose: To create a new instance of this class and initialize it's data
//
// Parameters: None
//
// Effects: See purpose
//
constructor TTableRestructure.Create;
begin
Fields := nil;
Operations := nil;
LocalFieldCount := 0;
end;
//
// Purpose: To delete a specific field from the tables description
//
// Parameters:
// Index - Index of the field that is to be removed
//
// Effects: The field is removed from the array of Field Descriptors and
// the memory that contains the list is reallocated
//
// Returns: True if the operation was successfull, False otherwise
//
function TTableRestructure.DeleteField(Index: Integer): Boolean;
var
FieldBefore,
FieldAfter: PFLDDesc;
OperationBefore,
OperationAfter: PCROpType;
begin
Result := False;
if (Fields <> nil) and (LocalFieldCount > 0) and (Index >= 0)
and(Index < LocalFieldCount) then begin
//Find the spot before and after the field to delete
FieldBefore := Fields;
FieldAfter := Fields;
Inc(FieldBefore, Index);
Inc(FieldAfter, Index + 1);
//Find the spot before and after the operation to delete
OperationBefore := Operations;
OperationAfter := Operations;
Inc(OperationBefore, Index);
Inc(OperationAfter, Index + 1);
//Now copy the data over the field to delete
Move(FieldAfter^, FieldBefore^, (LocalFieldCount - Index) * SizeOf(FLDDesc));
Move(OperationAfter^, OperationBefore^, (LocalFieldCount - Index) *
SizeOf(CROpType));
//Now shrink the allocated memory
Dec(LocalFieldCount);
ReallocMem(Fields, LocalFieldCount * SizeOf(FLDDesc));
ReallocMem(Operations, LocalFieldCount * SizeOf(CROpType));
Result := True;
end;
end;
//
// Purpose: To destroy an instance of this class and any memory that was
// allocated
//
// Parameters: None
//
// Effects: See purpose
//
destructor TTableRestructure.Destroy;
begin
DestroyFieldDescriptors;
end;
//
// Purpose: To destroy an array of field descriptors
//
// Parameters: None
//
// Effects: The Field Descriptors are freed, and the pointer set to nil
//
procedure TTableRestructure.DestroyFieldDescriptors;
begin
if Fields <> nil then begin
FreeMem(Fields);
Fields := nil;
FreeMem(Operations);
Operations := nil;
LocalFieldCount := 0;
end;
end;
//
// Purpose: To show the details of any Error returned by the BDE routines
//
// Parameters:
// ErrorCode - Code returned byt the BDE
//
// Effects: None
//
procedure TTableRestructure.DetailError(ErrorCode: DbiResult);
var
ErrorInfo: DBIErrInfo;
ErrorString: string;
ErrorString2: String;
begin
if (ErrorCode <> dbiERR_NONE) then begin
Check(DbiGetErrorInfo(True,ErrorInfo));
if (ErrorCode = ErrorInfo.iError) then begin
ErrorString := 'Error Number: ' + IntToStr(ErrorInfo.iError) + #10 + #13;
ErrorString := ErrorString + 'Error Code: ' + String(ErrorInfo.szErrcode) +
#10 + #13;
if (StrLen(ErrorInfo.szContext[1]) <> 0) then
ErrorString := ErrorString + 'Context1: ' + String(ErrorInfo.szContext[1]) +
#10 + #13;
if (StrLen(ErrorInfo.szContext[2]) <> 0) then
ErrorString := ErrorString + 'Context2: ' + String(ErrorInfo.szContext[2]) +
#10 +#13;
if (StrLen(ErrorInfo.szContext[3]) <> 0) then
ErrorString := ErrorString + 'Context3: ' + String(ErrorInfo.szContext[3]) +
#10 +#13;
if (StrLen(ErrorInfo.szContext[4]) <> 0) then
ErrorString := ErrorString + 'Context4: ' + String(ErrorInfo.szContext[4]) +
#10 +#13;
end
else begin
SetLength(ErrorString2, dbiMaxMsgLen + 1);
Check(DbiGetErrorString(ErrorCode, PChar(ErrorString2)));
SetLength(ErrorString2, StrLen(PChar(ErrorString2)));
ErrorString := ErrorString + ErrorString2;
end;
ShowMessage(ErrorString);
end;
end;
//
// Purpose: To find a particular field's index by it's name
//
// Parameters:
// Name - Name of the field to find in the current list of fields
//
// Effects: None
//
// Returns: Index of the field if found, or -1 if not found
//
function TTableRestructure.FindField(Name: String): Integer;
var
Index: Integer;
begin
Result := -1;
Index := FieldCount - 1;
while (Index >= 0) and (Result < 0) do begin
if CompareText(FieldName[Index], Name) = 0 then
Result := Index;
Dec(Index);
end;
end;
//
// Purpose: To return a pointer to a specified Field Descriptor
//
// Parameters:
// Index - Index of the field descriptor
//
// Effects: None
//
// Returns: Pointer to a Field Descriptor or nil if Index isn't valid
//
function TTableRestructure.GetField(Index: Integer): PFLDDesc;
begin
Result := nil;
if (Fields <> nil) and (Index >= 0) and (Index < LocalFieldCount) then begin
Result := Fields;
Inc(Result, Index);
end;
end;
//
// Purpose: Get method for the FieldLength property
//
// Parameters:
// Index - Index of a field descriptor
//
// Effects: None
//
// Returns: Length of the specified field or 0 if not field not found
//
function TTableRestructure.GetFieldLength(Index: Integer): Word;
var
Field: PFLDDesc;
begin
Result := 0;
Field := GetField(Index);
if Field <> nil then
Result := Field^.iLen;
end;
//
// Purpose: Get method for the FieldName property
//
// Parameters:
// Index - Index of a field descriptor
//
// Effects: None
//
// Returns: Name of the specified field or '' if not field not found
//
function TTableRestructure.GetFieldName(Index: Integer): String;
var
Field: PFLDDesc;
begin
Result := '';
Field := GetField(Index);
if Field <> nil then
Result := String(Field^.szName);
end;
//
// Purpose: Get method for the FieldType property
//
// Parameters:
// Index - Index of a field descriptor
//
// Effects: None
//
// Returns: Type of the specified field or -1 if not field not found
//
function TTableRestructure.GetFieldType(Index: Integer): Word;
var
Field: PFLDDesc;
begin
Result := 0;
Field := GetField(Index);
if Field <> nil then
Result := Field^.iFldType;
end;
//
// Purpose: Get method for the FieldUnits property
//
// Parameters:
// Index - Index of a field descriptor
//
// Effects: None
//
// Returns: Units1 of the specified field or -1 if not field not found
//
function TTableRestructure.GetFieldUnits(Index: Integer): Word;
var
Field: PFLDDesc;
begin
Result := 0;
Field := GetField(Index);
if Field <> nil then
Result := Field^.iUnits1;
end;
//
// Purpose: To get a pointer to an operation type
//
// Parameters:
// Index - Index of the operation that is desired
//
// Effects: None
//
// Returns: See purpose
//
function TTableRestructure.GetOperation(Index: Integer): PCROpType;
begin
Result := nil;
if (Index >= 0) and (Index < FieldCount) then begin
Result := Operations;
Inc(Result, Index);
end;
end;
//
// Purpose: To load in the table structure of the specified table
//
// Parameters:
// Table - Table whose structure will be loaded into memory
//
// Effects: Any previous structure is destroyed and replaced by the new
// structure if the table could be opened successfully
//
procedure TTableRestructure.LoadTableStructure(Table: TTable);
var
Index: Integer;
Field: PFLDDesc;
begin
DestroyFieldDescriptors;
if (Table <> nil) then begin
Table.Open;
LocalFieldCount := Table.FieldCount;
Fields := AllocMem(LocalFieldCount * SizeOf(FLDDesc));
try
Operations := AllocMem(LocalFieldCount * SizeOf(CROpType));
try
FillChar(Operations^, LocalFieldCount * SizeOf(CROpType), crNOOP);
Check(DbiGetFieldDescs(Table.Handle, Fields));
Field := Fields;
for Index := 1 to LocalFieldCount do begin
Field^.iFldNum := Index;
Inc(Field);
end;
except
FreeMem(Operations);
Operations := nil;
raise;
end;
except
FreeMem(Fields);
Fields := nil;
raise;
end;
end;
end;
//
// Purpose: No real purpose, other than for dumping out the current field data
//
// Parameters: None
//
// Effects: None
//
procedure TTableRestructure.PrintStructure;
var
Index: Integer;
Field: pFLDDesc;
Op: PCROpType;
Item: String;
List: String;
begin
List := '';
Field := Fields;
Op := Operations;
for Index := 0 to LocalFieldCount - 1 do begin
Item := Format('%d - %x - %s', [Field^.iFldNum, Byte(Op^), Field^.szName]);
List := List + Item + #10 + #13;
Inc(Field);
Inc(Op);
end;
ShowMessage(List);
end;
//
// Purpose: To modify a existing table to match the given field
// descriptors
//
// Parameters:
// Table - Table whose structure will be replaced by the structure in memory
//
// Effects: The table's structure is modified to match the current structure in
// memory. Once this is done, changes can not be undone.
//
procedure TTableRestructure.SaveTableStructure(Table: TTable);
var
TableDesc: CRTblDesc;
hDb: hDBIDb;
begin
Table.Open;
FillChar(TableDesc, sizeof(TableDesc), 0);
// Get the database handle from the table's cursor handle...
Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));
StrPCopy(TableDesc.szTblName, Table.TableName);
TableDesc.iFldCount := LocalFieldCount;
TableDesc.pecrFldOp := Operations;
TableDesc.pFldDesc := Fields;
Table.Close;
DetailError(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False));
end;
//
// Purpose: Set method for the FieldLength property
//
// Parameters:
// Index - Index of the Field to modify
// Value - New length of the field
//
// Effects: The field descriptor is modified to reflect the change
//
procedure TTableRestructure.SetFieldLength(Index: Integer;
const Value: Word);
var
Field: PFLDDesc;
Operation: PCROpType;
begin
Field := GetField(Index);
if Field <> nil then begin
Field^.iLen := Value;
Operation := GetOperation(Index);
if Operation^ <> crAdd then
Operation^ := crMODIFY;
end;
end;
//
// Purpose: Set method for the FieldName property
//
// Parameters:
// Index - Index of the Field to modify
// Value - New Name of the field
//
// Effects: The field descriptor is modified to reflect the change
//
procedure TTableRestructure.SetFieldName(Index: Integer;
const Value: String);
var
Field: PFLDDesc;
Operation: PCROpType;
begin
Field := GetField(Index);
if Field <> nil then begin
StrPCopy(Field^.szName, Value);
Operation := GetOperation(Index);
if Operation^ <> crAdd then
Operation^ := crMODIFY;
end;
end;
//
// Purpose: Set method for the FieldType property
//
// Parameters:
// Index - Index of the Field to modify
// Value - New Type of the field
//
// Effects: The field descriptor is modified to reflect the change
//
procedure TTableRestructure.SetFieldType(Index: Integer;
const Value: Word);
var
Field: PFLDDesc;
Operation: PCROpType;
begin
Field := GetField(Index);
if Field <> nil then begin
Field^.iFldType := Value;
Operation := GetOperation(Index);
if Operation^ <> crAdd then
Operation^ := crMODIFY;
end;
end;
//
// Purpose: Set method for the FieldUnits property
//
// Parameters:
// Index - Index of the Field to modify
// Value - New units of the field
//
// Effects: The field descriptor is modified to reflect the change
//
procedure TTableRestructure.SetFieldUnits(Index: Integer;
const Value: Word);
var
Field: PFLDDesc;
Operation: PCROpType;
begin
Field := GetField(Index);
if Field <> nil then begin
Field^.iUnits1 := Value;
Operation := GetOperation(Index);
if Operation^ <> crAdd then
Operation^ := crMODIFY;
end;
end;
end.
--
_________________
Brett W. Fleming
Software Engineer
VTLS, Inc.
~~~~~~~~~~~~~~~~~