cp_s22en.pas

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

unit cp_s22en;

interface

uses {$IFDEF WIN32} BDE,Windows,ComCtrls,{$ELSE}Winprocs,{$ENDIF}
  SysUtils, WinTypes, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, DB, DBTables, DbiProcs, DbiErrs,
  DbiTypes, DBConsts, ExtCtrls, Mask, Grids, DBGrids, FileCtrl, DBCtrls,
  TabNotBk,Menus,Printers, LibCs;

type
  TCopia_Dbf = class(TForm)
    Table2: TTable;
    DS1: TDataSource;
    DS2: TDataSource;
    Query1: TQuery;
    DataSource1: TDataSource;
    TN1: TTabbedNotebook;
    DBNavigator1: TDBNavigator;
    DBGrid1: TDBGrid;
    Label6: TLabel;
    CbTipoTabla: TComboBox;
    Label5: TLabel;
    EditFic: TEdit;
    EditDirectory: TEdit;
    Label3: TLabel;
    DriveComboBox1: TDriveComboBox;
    Directory1: TDirectoryListBox;
    Panel1: TPanel;
    Edit1: TEdit;
    Edit2: TEdit;
    DBNavigator2: TDBNavigator;
    DBGrid2: TDBGrid;
    BMove1: TBatchMove;
    MainMenu1: TMainMenu;
    Copiar1: TMenuItem;
    TablassinIndices1: TMenuItem;
    TablasIndices1: TMenuItem;
    Exportar1: TMenuItem;
    Tablaordebnada1: TMenuItem;
    FiltroSQL1: TMenuItem;
    Ordenar1: TMenuItem;
    TablaporunIndice1: TMenuItem;
    Ver1: TMenuItem;
    Filtros1: TMenuItem;
    Salida1: TMenuItem;
    Sql1: TMenuItem;
    Query2: TMenuItem;
    Utilidades1: TMenuItem;
    Indexar1: TMenuItem;
    Empaquetar1: TMenuItem;
    Acercade1: TMenuItem;
    Salir1: TMenuItem;
    Estructura1: TMenuItem;
    SQL2: TMenuItem;
    Ejecutar1: TMenuItem;
    Memo2: TMemo;
    Memo1: TMemo;
    Label8: TLabel;
    EditRecordQuery: TEdit;
    Label10: TLabel;
    Label9: TLabel;
    BBSql: TBitBtn;
    Label12: TLabel;
    Buffer: TEdit;
    Heap: TEdit;
    Controladores: TEdit;
    Clientes: TEdit;
    Sesiones: TEdit;
    BasesDatos: TEdit;
    Cursores: TEdit;
    Compartir: TEdit;
    TipoRed: TEdit;
    NombreUsuario: TEdit;
    ArchivoConfiguracion: TEdit;
    ControladorLenguaje: TEdit;
    Timer1: TTimer;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    GroupBox1: TGroupBox;
    CBAlias: TComboBox;
    Label2: TLabel;
    CBTable: TComboBox;
    Label7: TLabel;
    EditRegistros: TEdit;
    Label4: TLabel;
    CBIndex: TComboBox;
    EditAlias: TEdit;
    EditTable: TEdit;
    EditIndex: TEdit;
    Label1: TLabel;
    Label11: TLabel;
    Label13: TLabel;
    Database1: TDatabase;
    Label14: TLabel;
    Imprimir1: TMenuItem;
    PrintSql: TBitBtn;
    EditRegistro: TEdit;
    Label18: TLabel;
    CheckBox1: TCheckBox;
    SGrid1: TStringGrid;
    EditNear: TEdit;
    Label15: TLabel;
    Label16: TLabel;
    EditRanStart: TEdit;
    Label17: TLabel;
    EditRanEnd: TEdit;
    SpeedButton1: TSpeedButton;
    N1: TMenuItem;
    IndexInfo: TComboBox;
    Label19: TLabel;
    Label20: TLabel;
    MaskEdit1: TMaskEdit;
    Label21: TLabel;
    OpenDialog1: TOpenDialog;
    SpeedButton2: TSpeedButton;
    SpeedButton3: TSpeedButton;
    Label22: TLabel;
    Table1: TTable;
    IndexInNewForm1: TMenuItem;
    PackwithNewForm1: TMenuItem;
    Session1: TSession;
    procedure FormCreate(Sender: TObject);
    procedure CBAliasChange(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure CBTableChange(Sender: TObject);
    procedure EditFicKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure DirectoryEnter(Sender: TObject);
    procedure DirectoryExit(Sender: TObject);
    procedure RbCopySortKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure CBAliasKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure CBTableKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure CBIndexKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure CBAliasEnter(Sender: TObject);
    procedure CBAliasExit(Sender: TObject);
    procedure CBTableEnter(Sender: TObject);
    procedure CBTableExit(Sender: TObject);
    procedure CBIndexEnter(Sender: TObject);
    procedure CBIndexExit(Sender: TObject);
    procedure RbCopiarSoloDatosKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure RbCopiarTodoKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure CbTipoTablaEnter(Sender: TObject);
    procedure CbTipoTablaExit(Sender: TObject);
    procedure CbTipoTablaKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Directory1Change(Sender: TObject);
    procedure BBSQLClick(Sender: TObject);
    procedure TN1Click(Sender: TObject);
    procedure TablassinIndices1Click(Sender: TObject);
    procedure TablaporunIndice1Click(Sender: TObject);
    procedure FiltroSQL1Click(Sender: TObject);
    procedure Tablaordebnada1Click(Sender: TObject);
    procedure TablasIndices1Click(Sender: TObject);
    procedure Ejecutar1Click(Sender: TObject);
    procedure Salir1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure CBIndexChange(Sender: TObject);
    procedure Filtros1Click(Sender: TObject);
    procedure Sql1Click(Sender: TObject);
    procedure Query2Click(Sender: TObject);
    procedure Estructura1Click(Sender: TObject);
    procedure Explorer1Click(Sender: TObject);
    procedure Indexar1Click(Sender: TObject);
    procedure Empaquetar1Click(Sender: TObject);
    procedure Acercade1Click(Sender: TObject);
    procedure DS1DataChange(Sender: TObject; Field: TField);
    procedure CheckBox1Click(Sender: TObject);
    procedure EditNearChange(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure EditRanStartKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure PrintSqlClick(Sender: TObject);
    procedure Imprimir1Click(Sender: TObject);
    procedure MaskEdit1Change(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
    procedure IndexInNewForm1Click(Sender: TObject);
    procedure PackwithNewForm1Click(Sender: TObject);
  public
    Contador,NTablas,k : Integer;
    Alias_S,Table_S,Index_S,Directory_T,Table_T : String;
    TableType_T : TTableType;
    function SortTable(Alias_S,Table_S,Index_S :String; var Retorno :String):Boolean;
    function CopySort(Alias_S,Table_S,Index_S,Directory_T,Table_T :String;
                      var Retorno :String; TableType_T : TTableType):Boolean;
    function CopyTableFull(Alias_S, Table_S, Table_T: String; var Retorno :String): Boolean;
    procedure InicioCopia;
    procedure Mensaje(Escribe : String);
    procedure HandleExcepcion(Sender: TObject; E: Exception);
    procedure ChangeDataBaseName;
  end;

var
  Copia_Dbf  : TCopia_Dbf;
  RecordToCopy, RecordCopy : Integer;

implementation

uses ToolsDb, Index, Pack;

{$R *.DFM}

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

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

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

 {To launch the procedures of data update}
 CbAliasChange(nil);
 CbTipoTabla.ItemIndex := 0;
 EditDirectory.Text    := Directory1.Directory;
 if Copy(EditDirectory.Text,Length(EditDirectory.Text),1) <> '\'
 then EditDirectory.Text := EditDirectory.Text + '\';

 with SGrid1 do begin
  Cells[0,0]   := 'Field';
  Cells[1,0]   := 'Type';
  Cells[2,0]   := 'Size';
  Cells[3,0]   := 'Required';
  ColWidths[0] := Round(DefaultColWidth * 1.65);
  ColWidths[2] := Round(DefaultColWidth / 1.5);
  ColWidths[3] := Round(DefaultColWidth / 1.5);
  Width        := 379;
 end;
end;

procedure TCopia_Dbf.CBAliasChange(Sender: TObject);
begin
 Screen.Cursor  := CrHourGlass;
 EditAlias.Text := CbAlias.Items[CbALias.ItemIndex];
 ChangeDataBaseName;
end;

procedure TCopia_Dbf.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 Release;
end;

procedure TCopia_Dbf.CBTableChange(Sender: TObject);
var
 k       : integer;
 Table_S : String;
begin
 {To refresh data upon changing of table}
 Screen.Cursor         := CrHourGlass;
 CbTable.Refresh;
 if CbTable.ItemIndex > 0 then begin
  k := 1;
  while CbIndex.Items[k] <> '' do CbIndex.Items.Delete(k);

  with Table1 do begin
   DisableControls;
   Close;
   DatabaseName := EditAlias.Text;
   TableName    := CbTable.Items[CbTable.ItemIndex];
   IndexName    := '';
   Open;
   EditRegistros.Text  := IntToStr(RecordCount);
   GetIndexNames(CbIndex.Items);

   {To happen the characteristic of the fields to the grid}
   with SGrid1 do begin
    Cells[0,0] := 'Fields';
    Cells[1,0] := 'Type';
    Cells[2,0] := 'Size';
    Cells[3,0] := 'Required';
    RowCount := FieldCount + 1;
    for K := 0 to FieldCount - 1 do begin
     Cells[0,k+1] := FieldDefs.Items[k].Name;
     Cells[1,k+1] := GetFieldType(FieldDefs.Items[k].DataType);

     case FieldDefs.Items[k].DataType of
      ftString, ftBCD, ftBytes, ftVarBytes, ftBlob,
      ftMemo , ftGraphic : Cells[2,k+1] := IntToStr(Table1.FieldDefs.Items[K].Size);
     else
      Cells[2,k+1] := '';
     end;
     if FieldDefs.Items[K].Required then Cells[3,k+1] := 'True'
     else Cells[3,k+1] := 'False';
    end;
   end;

    Close;
    EnableControls;
   end;

   if CbIndex.Items[0] <> '< Natural Order >' then
    CbIndex.Items.Insert(0, '< Natural Order >');

   CbIndex.ItemIndex := 0;
   EditTable.Text    := CbTable.Items[CbTable.ItemIndex];
   EditIndex.Text    := '< Natural Order >';
 end;
 Screen.Cursor      := CrDefault;

 {To configure the head-board of the SQL text and tables and fields information}
 if CbTable.Items[CbTable.ItemIndex] <> '< All Tables >' then begin
  with Memo1 do begin
   Text := '';
   Lines.Add('Select * ');
   Table_S := CbTable.Items[CbTable.ItemIndex];
   if Pos('.',Table_S) > 0 then Table_S := Copy(Table_S,1,Pos('.',Table_S)-1);
   Lines.Add('From ' + Table_S);
   Lines.Add('Where ');
   Lines.Add(' Like ' + Chr(39) + '%%' + Chr(39));
  end;
 end;
end;

procedure TCopia_Dbf.EditFicKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if Key = VK_RETURN then CbTipoTabla.SetFocus;
end;

procedure TCopia_Dbf.DirectoryEnter(Sender: TObject);
begin
 Directory1.Color := clWhite;
end;

procedure TCopia_Dbf.DirectoryExit(Sender: TObject);
begin
 Directory1.Color := clSilver;
end;

procedure TCopia_Dbf.RbCopySortKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if Key = VK_RETURN then CbAlias.SetFocus;
end;

procedure TCopia_Dbf.CBAliasKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if Key = VK_RETURN then CbTable.SetFocus;
end;

procedure TCopia_Dbf.CBTableKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if (Key = VK_RETURN)then Directory1.SetFocus
 else CbIndex.SetFocus;
end;

procedure TCopia_Dbf.CBIndexKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if Key = VK_RETURN then EditFic.SetFocus;
end;

procedure TCopia_Dbf.CBAliasEnter(Sender: TObject);
begin
 Screen.Cursor           := CrHourGlass;
 try
  Session.Close;
  Session.GetAliasNames(CbAlias.Items);
  CbAlias.ItemIndex := 0;
 finally
  Screen.Cursor     := CrDefault;
 end;
 CbAlias.Color := clWhite;
end;

procedure TCopia_Dbf.CBAliasExit(Sender: TObject);
begin
 CbAlias.Color := clSilver;
end;

procedure TCopia_Dbf.CBTableEnter(Sender: TObject);
begin
 CbTable.Color := clWhite;
end;

procedure TCopia_Dbf.CBTableExit(Sender: TObject);
begin
 CbTable.Color := clSilver;
end;

procedure TCopia_Dbf.CBIndexEnter(Sender: TObject);
begin
 CbIndex.Color := clWhite;
end;

procedure TCopia_Dbf.CBIndexExit(Sender: TObject);
begin
 CbIndex.Color := clSilver;
end;

procedure TCopia_Dbf.RbCopiarSoloDatosKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if Key = VK_RETURN then CbAlias.SetFocus;
end;

procedure TCopia_Dbf.RbCopiarTodoKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 if Key = VK_RETURN then CbAlias.SetFocus;
end;

function TCopia_Dbf.SortTable(Alias_S,Table_S,Index_S :String;var Retorno :String):Boolean;
var
 Field_Number : Integer;
begin

 {Ctrl. Alias}
 if Length(Alias_S) = 0 then begin
  Retorno := ('The data Alias must be selected.');
  Result  := False;
  Exit;
 end;

 {Ctrl. Tabla}
 if (Length(Table_S) = 0) or (Table_S = '< All Tables >') then begin
  Retorno := 'To select Table to Sort.';
  Result  := False;
  Exit;
 end;

 {Ctrl. Index}
 if (Length(Index_S) = 0) or (Index_S = '< Natural Order >') then begin
  Retorno := 'To select the Index to order.';
  Result  := False;