How to restructure a TTable

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.