unit Packtbl;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  DB, DBTables, DBiTypes;

type
  TPackTable = class(TTable)
  private
    { Private declarations }
  protected
    { Protected declarations }
    procedure PackError( Error : DBIResult); virtual;
  public
    { Public declarations }
    procedure Pack;
  published
    { Published declarations }
  end;

procedure Register;

implementation

uses DBiProcs, DbiErrs;

procedure TPackTable.Pack;
var OldExclusiveState, OldActiveState : Boolean;
    TableDescription : pCRTblDesc;
    TempResult : DBIResult;
    TempDbHandle : hDBIdb;
    ExtType : TTableType;
    TableNameExt : String;
begin
    OldExclusiveState := Exclusive;
    OldActiveState := Active;
    DisableControls;

    if Active and (not Exclusive) then Close;
    if (not Exclusive) then Exclusive := True;
    if (not Active) then Open;
    TempDbHandle := DBHandle;

    TableNameExt := UpperCase(ExtractFileExt(TableName));
    if TableNameExt = '.DBF' then ExtType := ttdBase else
    if ((TableNameExt = '.DB') or
        (TableNameExt = '')) then ExtType := ttParadox;

    TempResult := DBIERR_NOTSUPPORTED;
    if (TableType = ttdBase) or ((TableType = ttDefault) and (ExtType = ttdBase)) then
    begin
        tempResult := DbiPackTable(DBHandle, Handle, nil, nil, True);
    end else
    if (TableType = ttParadox) or
      ((TableType = ttDefault) and
       (ExtType = ttParadox)) then
    begin
        New(TableDescription);
        FillChar(TableDescription^, SizeOf(TableDescription^), 0);

        with TableDescription^ do
        begin
            bPack := True;
            StrPCopy(szTblName, TableName);
            StrPCopy(szTblType, szParadox);
        end;

        Close;
        TempResult := DbiDoRestructure(TempDBHandle, 1, TableDescription, nil, nil, nil, False);
    end;

    if TempResult <> DBIERR_NONE then PackError(TempResult);

    Close;
    Exclusive := OldExclusiveState;
    Active := OldActiveState;
    EnableControls;
end;


procedure TPackTable.PackError(Error : DBIResult);
var ErrorString : DBIMSG;
begin
    DbiGetErrorString(Error, ErrorString);
    ShowMessage(ErrorString);
end;



procedure Register;
begin
  RegisterComponents('NileX', [TPackTable]);
end;

end.