pack.pas

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

{Form for Pack.

 It is convenient before calling it, to make it a Session.Close; to be assured
 of the fact that all tables are closed}

unit Pack;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, DB, DBTables, DbiProcs, DbiErrs,
  DbiTypes, ExtCtrls, ComCtrls, LibCs;

type
  TFPack = class(TForm)
    Label1: TLabel;
    CBALias: TComboBox;
    TablePack: TTable;
    Label2: TLabel;
    CBTabla: TComboBox;
    BotonSalir: TBitBtn;
    BotonReconstruir: TBitBtn;
    Edit2: TEdit;
    Edit1: TEdit;
    ProgressBar1: TProgressBar;
    SpeedButton2: TSpeedButton;
    OpenDialog1: TOpenDialog;
    procedure FormCreate(Sender: TObject);
    procedure CbAliasChange(Sender: TObject);
    procedure BotonReconstruirClick(Sender: TObject);
    procedure BotonSalirClick(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure CBTablaChange(Sender: TObject);
  public
    procedure Mensaje(Escribe : String);
    procedure HandleExcepcion(Sender: TObject; E: Exception);
    procedure ChangeDataBaseName(sDataBaseName : String);
    function Pack(Alias,Tabla : String; var Error : String) : Boolean;
  end;

var
  FPack: TFPack;

implementation

{$R *.DFM}

procedure TFPack.HandleExcepcion(Sender: Tobject; E: Exception);
begin
 if E.Message <> '' then begin
  Screen.Cursor := crArrow;
  MessageDlg(E.Message, mtError, [mbOK], 0);
 end;
end;

procedure TFPack.Mensaje(Escribe : String);
begin
 Edit1.Text := Escribe;
 Edit1.Refresh;
end;

function  TFPack.Pack(Alias,Tabla : String; var Error : String) : Boolean;
begin
 Result := False;

 if TablePack.Active then TablePack.Active := False;

 TablePack.DatabaseName := Alias;
 TablePack.TableName    := Tabla;

 Screen.Cursor             := CrHourGlass;
 try
  Mensaje('Opening ' + Tabla + '...');
  TablePack.Open;
 except
  TablePack.Close;
 end;
 Screen.Cursor := CrDefault;

 if not TablePack.Active then
  Error := 'It is not possible to open the table' + Tabla
 else begin
  Mensaje('Packing the Table ' + Tabla + '...');
  Screen.Cursor := crHourGlass;
  if not fDbiPackTable(TablePack,
                       True, // Index to ended, True o False
                       Retorno) then ShowMessage(Retorno)
  else Result := True;
 end;
 Mensaje('');
 Screen.Cursor := CrDefault;
end;

procedure TFPack.FormCreate(Sender: TObject);
begin
 Application.OnException := HandleExcepcion;
 Screen.Cursor := CrHourGlass;
 try
  Session.GetAliasNames(CbAlias.Items);
  CbAlias.ItemIndex := 0;
 finally
  Screen.Cursor := CrDefault;
 end;
 CbAliasChange(nil);
end;

procedure TFPack.CBALiasChange(Sender: TObject);
begin
 ChangeDataBaseName(CbAlias.Items[CbAlias.ItemIndex]);
end;

procedure TFPack.BotonReconstruirClick(Sender: TObject);
var
  Contador: Integer;
  NTablas : Integer;
  strError: string;
begin
 ProgressBar1.Position := 0;
 strError := '';
 if CbTabla.ItemIndex > 0 then begin
  if not Pack(CbAlias.Items[CbAlias.ItemIndex],
              CbTabla.Items[CbTabla.ItemIndex],
              strError)
  then MessageDlg('Can not Pack ' + cbTabla.Items[ cbTabla.ItemIndex ] +
                  '.  Reason: ' +  '. ' +
                  #10 + #10 + strError, mtError, [mbOK], 0);
  ProgressBar1.Position := 100;
 end else begin {All Tables}
  NTablas := cbTabla.Items.Count;
  for Contador := 1 to cbTabla.Items.Count - 1 do begin
   Edit2.Text := IntToStr(NTablas - Contador);
   Edit2.Refresh;
   if not Pack(cbAlias.Items[cbAlias.ItemIndex],
               cbTabla.Items[Contador],
               strError)
   then MessageDlg('Can not Pack ' + cbTabla.Items[Contador] + '. ' +
                   #10 + #10 + '. Reason: ' + strError, mtError, [mbOK], 0 );

   ProgressBar1.Position := Round((Contador * 100) / NTablas);

  end;

  if Contador = NTablas then ProgressBar1.Position := 100;

  Edit2.Text := '';
  Edit2.Refresh;
  BotonSalir.SetFocus;
 end;
 Mensaje('Pack ended.');
end;

procedure TFPack.BotonSalirClick(Sender: TObject);
begin
 Close;
end;

procedure TFPack.SpeedButton2Click(Sender: TObject);
var
 s : String;
begin
 if OpenDialog1.Execute then begin
  s := UpperCase(OpenDialog1.FileName);
  {Get path only}
  while (s[Length(s)] <> '\') and (Length(s) > 0) do s := Copy(s,1,Length(s)-1);

  CbAlias.Items.Insert(0, s);
  CbAlias.ItemIndex := 0;
  ChangeDataBaseName(s);
 end;
end;

procedure TFPack.ChangeDataBaseName(sDataBaseName : String);
begin
 Screen.Cursor         := crHourGlass;
 Edit1.Text            := '';
 ProgressBar1.Position := 0;
 try
  with CbTabla do begin
   Session.GetTableNames(sDataBaseName,'',True,False,Items);
   Items.Insert(0, '< All Tables >');
   ItemIndex := 0;
  end;
 finally
  Screen.Cursor      := crDefault;
 end;
end;

procedure TFPack.CBTablaChange(Sender: TObject);
begin
 Edit1.Text            := '';
 ProgressBar1.Position := 0;
end;

end.