unit Dbutl;
interface
uses
  SysUtils, {v0.48}Classes, {/v0.48} Dialogs, DB, DBTables, DBiTypes, DBiProcs, DBiErrs;

function PackTable(ATable:TTable):boolean;
function ZapTable(ATable:TTable):boolean;

function SelectIndexName(var ATable:TTable; AIndexName:string):boolean;
{tries to select specified index name; returns false if no such index exists}
{ulantype}

{v0.48}
const
  DefTableType: TTableType = ttParadox;
  DefDBExt: string = '.db';

{XTable template}
type
  TTableCreate = procedure(ATable: TTable);

{Example of TableCreate procedure (asuming databasename and table name are set)

  procedure TableCreate(ATable: TTable);
  begin
    with ATable do begin
      // Next, describe the fields in the table
      fields
      with FieldDefs do
      begin
        Clear;
        with AddFieldDef do begin
          Name := 'Name1';
          DataType := ftInteger;
          Required := true;
          Size := 0;
          // Precission := 0;
           // type TFieldType = (ftUnknown, ftString, ftSmallint, ftInteger, ftWord,
           //  ftBoolean, ftFloat, ftCurrency, ftBCD, ftDate, ftTime, ftDateTime, ftBytes,
           //  ftVarBytes, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle,
           //  ftDBaseOle, ftTypedBinary, ftCursor, ftFixedChar, ftWideString, ftLargeint,
           // ftADT, ftArray, ftReference, ftDataSet);
          // Attributes := TFieldAttribute = (faHiddenCol, faReadonly, faRequired, faLink, faUnNamed);
          // ChildDefs :=
          // FieldClass :=
          // FieldNo :=
          // InternalCalcField
          // ParentDef :=
          // obsolete - Add('UsrID', ftInteger, 0, True);
        end;
        // Add('Field1', ftInteger, 0, True);
        // Add('Field2', ftString, 30, False);
      end;
      //  Next, describe any indexes
      with IndexDefs do
      begin
        Clear;
        if AddIndexDef do begin
          Name := 'FldIx1';
          Fields := 'Field1;Field2'
            //list of fields that create index expression
          Options :=
            // TIndexOption = (ixPrimary, ixUnique, ixDescending, ixCaseInsensitive, ixExpression, ixNonMaintained);
          // CaseInsFields
             // comma delimted list of fieldnames of fields that should be case insensitive
          // DescFields
            // comma delimited list of fieldname of fields that should be sorted in descending order
          // Expression
            // dBase expression (only for DBASE tables); used if ixExpression set (then Fields are not used
               and must be empty)
          // FieldExpression
          // GroupingLevel
          // Source
          // The first index has no name because it is a Paradox primary key

          //obsolete - Add call
           Add('', 'Field1', [ixPrimary, ixUnique]);
           Add('Fld2Indx', 'Field2', [ixCaseInsensitive]);
      end;
    end;
  end;
  }

function TableOpen(AOwner: TComponent; const ADatabaseName: string; const ATableName: string; ATableCreate: TTableCreate): TTable;
  { open table of given database name and tablename; if does not exist calls
    ATableCreate procedure }

function FindIndexName(AIndexDefs: TIndexDefs; const AFieldName: string; var AIndexName: string): boolean;

{/v0.48}
{v0.50}
function TableGetBrowseLine(ATable: TDataSet): string;
  { Returns concatenated Field.AsString values of all fields of current record }
{/v0.50}

implementation

type
  EDBPack = class(Exception);

function PackTable(ATable:TTable):boolean;
var Error:DBiResult;
begin
  Result := false;
  try
    with ATable do begin
      if TableType = ttDBase then begin
        DisableControls;
        Active := false;
        Exclusive := true;
        Active := true;
        Error := DBiPackTable(DBHandle, Handle, nil, nil, True);
        EnableControls;
        if Error = DBIERR_NONE then begin
          Result := true;
        end else begin
          raise EDBPack.Create('Nelze pakovat tento dBase soubor');
        end;
      end;
    end;
  except
    on E:EDBPack do
      MessageDlg(E.Message, mtError, [mbOK],0);
  end;
end;

function ZapTable(ATable:TTable):boolean;
begin
  ZapTable := false;
  ATable.DisableControls;
  try
    ATable.IndexName := '';
    ATable.First;
    while not ATable.EOF do begin
      ATable.Delete;
      ATable.First;
    end;
    ZapTable := PackTable(ATable);
  finally
    ATable.EnableControls;
  end;
end;

function SelectIndexName(var ATable:TTable; AIndexName:string):boolean;
begin
  ATable.IndexDefs.Update;
  if ATable.IndexDefs.IndexOf(AIndexName) >= 0 then begin
    ATable.IndexName := AIndexNAme;
    SelectIndexName := true;
  end else
    SelectIndexName := false;
end;
{tries to select specified index name; returns false if no such index exists}

{v0.48}
type
  TMTable = class(TTable)
  end;
  
function TableOpen(AOwner: TComponent; const ADatabaseName: string; const ATableName: string; ATableCreate: TTableCreate): TTable;
begin
  Result := TMTable.Create(AOwner);
  Result.DatabaseName := ADataBaseName;
  Result.TableName := ExtractFileName(ChangeFileExt(ATableName, ''));
  if not Result.Exists then begin
    {Result.Active := false;}
    Result.TableType := DefTableType;
    Result.FieldDefs.Clear;
    Result.IndexDefs.Clear;

    ATableCreate(Result);

    Result.CreateTable;
    {Result.IndexDefs.Update;}
  end;
  Result.Active := true;
end;

function FindIndexName(AIndexDefs: TIndexDefs; const AFieldName: string; var AIndexName: string): boolean;
var
  i: integer;
  id: TIndexDef;
  p: integer;
begin
  Result := false;
  AIndexDefs.Update;
  for i := 0 to AIndexDefs.Count - 1 do begin
    id := AIndexDefs[i];
    p := 1;
    if ExtractFieldName(id.Fields, p) = AFieldName then begin
      AIndexName := id.Name;
      Result := true;
      exit;
    end;
  end;
end;

{/v0.48}

{v0.50}
function TableGetBrowseLine(ATable: TDataSet): string;
var i: integer;
begin
  Result := '';
  for i := 0 to ATable.FieldCount - 1 do begin
    Result := Result + ATable.Fields[i].DisplayText + ' ';
  end;
end;
{/v0.50}

end.
