How to restructure a TTable (Views: 27)
Problem/Question/Abstract: How to restructure a TTable Answer: unit TTableRestruct; {Freeware by Brett W. Fleming 1999 SetOperation method added by Bill Todd 1999} interface uses BDE, DbTables; type TTableRestructure = class(TObject) 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); procedure SetOperation(Index: Integer; OpType: PCROpType); protected Fields: PFLDDesc; Operations: PCROpType; LocalFieldCount: Integer; procedure DestroyFieldDescriptors; public constructor Create; destructor Destroy; override; 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 write SetOperation; end; implementation uses SysUtils, Dialogs; {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 assign a new operation. Parameters: Index - Index of the operation that is desired Effects: None Returns: None} procedure TTableRestructure.SetOperation(Index: Integer; OpType: PCROpType); var ModifyOperations: PCROpType; begin ModifyOperations := Operations; Inc(ModifyOperations, Index); ModifyOperations^ := crModify; 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 := '# - Op - Type - Name' + #10#13; Field := Fields; Op := Operations; for Index := 0 to LocalFieldCount - 1 do begin Item := Format('%d - %x - %d - %s', [Field^.iFldNum, Byte(Op^), FieldType[Index], 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. |