libcs.pas

示范复制、排序、输出、过滤、查询、打印、压缩重整 ( Pack )、取得字段及索引信息的范例程序

unit LibCs;

interface

uses {$IFDEF WIN32} BDE,Windows, {ELSE} WinTypes,WinProcs,{$ENDIF}
     DbiErrs,DbiProcs,DbiTypes,DB,DBConsts,DBTables,Classes,SysUtils;

 function Ltrim(Cadena: string): string;
 function Rtrim(Cadena: string): string;
 function Alltrim(Cadena: string): string;
 function Space(I: Integer): string;
 function AlineaIzqda(Cadena: string;K:Integer): string;
 function fDbiPackTable(var TblName : TTable; bRegenIdxs: Boolean; var Retorno : String): Boolean;
 function fDbiRegenIndexes(var TblName : TTable ; var Retorno : String): Boolean;
 function fDbiSortTable(var SrcTbl, DestTbl: TTable; SortField: TField): longint;
 function GetFieldType(Tipo: TFieldType): string;
 function Recno(var ATable: TTable): Longint;
 function GotoRecNo(var Tabla : TTable; Registro : Longint; var Retorno : String): Boolean;

var
 Retorno : String;

implementation

// Eliminate the spaces to the left from a string
function Ltrim(Cadena: string): string;
begin
  while pos(' ',Cadena) = 1 do
   begin
      Cadena := Copy(Cadena,2,Length(Cadena)-1);
  end;
  Result:= Cadena;
end;

// Eliminate the spaces to the right from a chain
function Rtrim(Cadena: string): string;
begin
  while Copy(Cadena,Length(Cadena),1) = ' ' do
  begin
    Cadena := Copy(Cadena,1,Length(Cadena) - 1);
  end;
  Result:= Cadena;
end;

// Eliminate the spaces to the left and right from a chain
function Alltrim(Cadena: string): string;
begin
 Result:= Ltrim(Rtrim(Cadena));
end;

// Insert i spaces
function Space(I: Integer): String;
var
 k      : Integer;
 Cadena : string;
begin
 k      := 0;
 Cadena := '';
 while k < I do begin
  Cadena := Cadena + ' ';
  k      := K + 1;
 end;
 Result := Cadena;
end;

// Align to the Left filling spaces until completing length K
function AlineaIzqda(Cadena: string;K: Integer): string;
begin
 if k = 0 then k := Length(Cadena);
 if k < Length(Cadena) then k := Length(Cadena);
 Cadena := Ltrim(Cadena);
 Cadena := Cadena + Space(k - Length(Cadena));
 Result := Cadena;
end;

function fDbiPackTable(var TblName : TTable; bRegenIdxs: Boolean;
                       var Retorno : String): Boolean;
var
 BdeResult : DbiResult;
 Props: CURProps;
 hDb: hDBIDb;
 TableDesc: CRTblDesc;
 bActive,bExclusive : Boolean;
begin
(*
 if not fDbiPackTable(Table1,
                      True, // Index to ended, True o False
                      Retorno) then ShowMessage(Retorno);
*)

 with TblName do begin
  bActive    := Active;
  bExclusive := Exclusive;
  if Active then Close;
  if not Exclusive then Exclusive := True;
  try
   Open;
  except
   Retorno := 'Cannot open the table in exclusive manner';
   Result := False;
   Exit;
  end;
 end;

 // Get the table properties to determine table type...
 Check(DbiGetCursorProps(TblName.Handle, Props));

 if Props.szTableType = szDBase then begin
  BdeResult := DbiPackTable(TblName.DBHandle, TblName.Handle, nil,szDBase, bRegenIdxs);
  Case BdeResult of
   DBIERR_NONE           : Retorno := 'All table Indexes have been indexed';
   DBIERR_INVALIDHNDL    : Retorno := 'The Name of Table or the pointer to the same is Void';
   DBIERR_NOSUCHTABLE	 : Retorno := 'The Table ' + TblName.TableName + ' not found';
   DBIERR_UNKNOWNTBLTYPE : Retorno := 'The type of table is unknown';
   DBIERR_NEEDEXCLACCESS : Retorno := 'The Table '  + TblName.TableName + 'it must be opened in exclusive manner';
  else
   Retorno := 'The BDE returns a not waited error';
  end;
  Result := (BdeResult = DBIERR_NONE);
 end else begin // La tabla no es dBase. Suponemos que es Paradox
  try
   // Si la tabla es Paradox, se llama a DbiDoRestructure...
   if Props.szTableType = szPARADOX then begin
     // Iniciar la estructura
     FillChar(TableDesc, sizeof(TableDesc), 0);
     // Obtener el database handle desde la tabla
     Check(DbiGetObjFromObj(hDBIObj(TblName.Handle), objDATABASE, hDBIObj(hDb)));
     // Poner el nombre de la tabla en la descripci髇
     StrPCopy(TableDesc.szTblName, TblName.TableName);
     // Poner el tipo de la tabla en la Descripci髇
     StrPCopy(TableDesc.szTblType, Props.szTableType);
     // Configurar la opci髇 Empaquetar en la descripci髇
     TableDesc.bPack := True;
     // Cerrar la tabla antes de Reestructurar
     TblName.Close;
     // Llamar a DbiDoRestructure...
     Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False));
     Result := True;
    end;
   except
    Retorno := 'An exception has taken place when packing the Paradox  Table';
    Result := False;
   end;
 end;

 with TblName do begin
  Close;
  Exclusive := bExclusive;
  Active    := bActive;
 end;
end;

function fDbiRegenIndexes(var TblName : TTable ; var Retorno : String): Boolean;
var
 BdeResult : DbiResult;
 bActive,bExclusive : Boolean;
begin
(*
 // Example of calling to the function
 if not fDbiRegenIndexes(Table1, Retorno) then ShowMessage(Retorno);
*)

 with TblName do begin
  bActive    := Active;
  bExclusive := Exclusive;
  if Active then Close;
  if not Exclusive then Exclusive := True;
  try
   Open;
  except
   Retorno := 'Cannot open the table in exclusive manner';
   Result := False;
   Exit;
  end;
 end;

 BdeResult := DbiRegenIndexes(TblName.Handle);
 Case BdeResult of
  DBIERR_NONE           : Retorno := 'All table Indexes have been indexed';
  DBIERR_INVALIDHNDL    : Retorno := 'The Name of Table or the pointer to the same is Void.';
  DBIERR_NEEDEXCLACCESS : Retorno := 'The Table '  + TblName.TableName + ' it must be opened in exclusive manner';
  DBIERR_NOTSUPPORTED   : Retorno := 'DbiRegenIndexes it does not sustain tables SQL';
 else
  Retorno := 'The BDE returns a not waited error';
 end;
 Result := (BdeResult =DBIERR_NONE);

 with TblName do begin
  Close;
  Exclusive := bExclusive;
  Active    := bActive;
 end;

end;

{This is the original function of the BDE that permits to order by a Field of table.
 It is included in the example, but is not used}
function fDbiSortTable(var SrcTbl, DestTbl: TTable; SortField: TField): longint;
var
  Field: Word;
  CaseIns: boolean;
  Recs: longint;
begin
  Recs := SrcTbl.RecordCount;
  CaseIns := True;
  Field := SortField.Index + 1;

  if DestTbl.Active = False then
    raise EDatabaseError.Create('Cannot complete operation with destination table closed');

  Check(DbiSortTable(SrcTbl.DBHandle, nil, nil, SrcTbl.Handle, nil, nil,
           DestTbl.Handle, 1, @Field, @CaseIns, nil, nil, False, nil, Recs));

  Result := Recs;
end;

function GetFieldType(Tipo: TFieldType): string;
const
{$IFDEF WIN32}
 Types: array [ftUnknown..ftTypedBinary] of string [11] =
        ('Unknown', 'String', 'Smallint', 'Integer', 'Word', 'Boolean', 'Float',
         'Currency','BCD', 'Date', 'Time', 'DateTime', 'Bytes', 'VarBytes',
         'AutoInc','Blob', 'Memo', 'Graphic','FmtMemo','ParadoxOle','DBaseOle','TypedBinary');
{$ELSE}
 Types: array [ftUnknown..ftGraphic] of string [8] =
        ('Unknown', 'String', 'Smallint', 'Integer', 'Word', 'Boolean', 'Float',
         'Currency','BCD', 'Date', 'Time', 'DateTime', 'Bytes', 'VarBytes',
         'Blob', 'Memo', 'Graphic');
{$ENDIF}
begin
  if (Tipo < Low(Types)) or (Tipo > High(Types)) then Tipo := Low(Types);
  Result := Types[Tipo];
end;

function Recno(var ATable: TTable): Longint;
var
  CP: CurProps;
  RP: RecProps;
begin
 with ATable do begin
  { Make sure it is a Paradox table!}
  UpdateCursorPos;                { sync BDE with Delphi}
  { Find out if table support Seq nums or Physical Rec nums}
  Check(DbiGetCursorProps(Handle, CP));
  Check(DbiGetRecord(Handle, dbiNOLOCK, nil, @RP));
  if StrComp(CP.szTableType, szDBASE) = 0 then
   Result := RP.iPhyRecNum
  else
   if StrComp(CP.szTableType, szPARADOX) = 0 then
    Result := RP.iSeqNum
   else
    Result := 0;
    { raise exception if it's not a Paradox or dBASE table}
//    raise EDatabaseError.Create('Not a Paradox or dBASE table');
 end;
end;

function GotoRecNo(var Tabla : TTable; Registro : Longint; var Retorno : String): Boolean;
var
 BdeResult: DbiResult;
begin
 BdeResult:= DbiSetToRecordNo(Tabla.handle, Registro);
 Case BdeResult of
  DBIERR_NONE        : Result := True; {The cursor was successfully set to the record specified by iRecNo.}
  DBIERR_INVALIDHNDL : begin
                        Retorno := 'The specified cursor handle is invalid or NULL.';
                        Result  := False;
                       end;
  DBIERR_BOF         : begin {The specified record number is zero.}
                        Tabla.First;
                        Result := True;
                       end;
  DBIERR_EOF         : begin {The specified record number is greater than the number of records in the table.}
                        Tabla.Last;
                        Result := True;
                       end;
  DBIERR_NOTSUPPORTED : begin
                        Retorno := 'This function is not supported for Paradox and SQL tables.';
                        Result  := False;
                       end;
 else
  Result  := False;
  Retorno := 'The BDE returns a unexpected error';
 end;

 Tabla.Resync([]);
end;

end.