cp_s22en.pas

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

  Exit;
 end;

 {# Config tables Source and Target}
 try
  with Table1 do begin
   Close;
   DatabaseName  := Alias_S;
   TableName     := Table_S;
   IndexName     := '';
   Open;
   RecordToCopy  := RecordCount;
   Close;
   IndexName     := Index_S;
   Open;
  end;

 except
  Table1.Close;
  Retorno := 'Error upon copying data to temporary Table.';
  Result  := False;
  Exit;
 end;

 if not CopyTableFull(Alias_S,      {Alias Source}
                      Table_S,      {Table Source}
                      'Tmp.Dbf',    {Table Target temporary}
                      Retorno)      {Message of result}
 then begin
  Retorno := 'Error produced upon copying ' + Alias_S + ' in tmp.dbf.';
  Result  := False;
  Exit;
 end;

 with Table2 do begin
  Close;
  DatabaseName := Alias_S;
  TableName    := 'Tmp.Dbf';
  IndexName    := Index_S;
 end;

 Table2.Open;
 Edit2.Text := IntToStr(Table2.RecordCount);
 Edit2.Refresh;

 {# Ctrl. of the fact that temporary table has records before erasing the previous}
 if Table2.RecordCount = 0 then begin
  Result  := False;
  Retorno := 'Error upon adding data in Tmp.dbf . 0 register copied';
  Exit;
 end;

 Table2.First;
 RecordCopy := 0;
 while not Table2.Eof do begin
  RecordCopy := RecordCopy + 1;
  Table2.Next;
 end;

 {# Control of the fact that it has copied less records of those which tape-worm
    in origin by be an  index with conditions UNIQUE}
 if RecordCopy < RecordToCopy then
  if MessageDlg('The selected Index磗 condition is ++UNIQUE' + #13 +
                'and will lose data. Cancel the operation ?',
                mtInformation, [mbYes, mbNo], 0) = mrYes then
  begin
   Result  := False;
   Retorno := 'Operation aborted by having condition UNIQUE';
   Table2.Close;
   Exit;
  end;

 Table2.Close;

 {# To erase table of origin after proving that we have copied the all records}
 with Table1 do begin
  try
   Close;
   Exclusive := True;
   Open;
   EmptyTable;
   Close;
   Exclusive := False;
   Open;
  except
   Close;
   Retorno := 'Error upon erasing Table ' + TableName;
   Result  := False;
   Exit;
  end;
 end;

 {# To happen the data of temporary table tmp.dbf-Table2 to Table1}
 Table2.Open;
 Table2.First;
 RecordCopy := 0;
 try
  while not Table2.Eof do begin
   Table1.Edit;
   Table1.Insert;
   for Field_Number := 0 to Table2.FieldCount - 1 do
    Table1.Fields[Field_Number].Assign(Table2.Fields[Field_Number]);

   Table1.Post;
   RecordCopy := RecordCopy + 1;
   Table2.next;
  end;
 except
  Table1.Close;
  Table2.Close;
  Retorno := 'Error upon ordering data and to copy in ' + Table1.TableName;
  Result  := False;
  Exit;
 end;
 Retorno := 'Sort of Tabla - ' + Table_S + ' - finish.' +
            IntToStr(RecordCopy) + ' Register copied';
 Table1.Close;
 Table2.Close;
 Result  := True;

end;

function TCopia_Dbf.CopySort(Alias_S,Table_S,Index_S,Directory_T,Table_T :String;
                             var Retorno :String; TableType_T : TTableType):Boolean;
begin

 {Ctrl. Alias}
 if Length(Alias_S) = 0 then begin
  Retorno := ('To select the Alias or directory of Data.');
  Result  := False;
  Exit;
 end;

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

 {# Ctrl. Index. Also it is possible to export table by Orden Natural }
 if (Length(Index_S) = 0) or (Index_S = '< Natural Order >') then begin
  Index_S := '';
 end;

 {# Ctrl. of the extension of the file. It is acquittance if it has}
 if Pos('.',Table_T) > 0 then begin
  while Pos('.',Table_T) = 1 do Table_T := Copy(Table_T,2,Length(Table_T) - 1);
  while pos('.',Table_T) > 0 do Table_T := Copy(Table_T,1,Pos('.',Table_T)-1);
 end;

 {# Config Tables}
 try
  with Table1 do begin
   Close;
   DatabaseName := Alias_S;
   TableName    := Table_S;
   IndexName    := Index_S;
   Open;
  end;

  with Table2 do begin
   Close;
   DatabaseName := Directory_T;
   TableName    := Table_T;
   TableType    := TableType_T;
  end;

  {# Execute the data copy

   ## The component TBatchMove has some Bug and not always works well.
      In some occasions and in the same conditions not copy nothing.}

  RecordCopy := Table2.BatchMove(Table1, BatCopy);
  Retorno    := 'Copy ordered to the file - ' + Table_T + ' - finish. ' +
                IntToStr(RecordCopy) + ' Register copied.';
  Result     := True;
 except
  Table1.Close;
  Table2.Close;
  Result  := False;
  Retorno := 'Error upon making the ordered copy';
 end;
end;

procedure TCopia_Dbf.CbTipoTablaEnter(Sender: TObject);
begin
 CbTipoTabla.Color := clWhite;
end;

procedure TCopia_Dbf.CbTipoTablaExit(Sender: TObject);
begin
 CbTipoTabla.Color := clSilver;
end;

procedure TCopia_Dbf.CbTipoTablaKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 Directory1.SetFocus;
end;

function TCopia_Dbf.CopyTableFull(Alias_S, Table_S, Table_T: String; var Retorno :String): Boolean;
var
 pTable_S, pTable_T : array[0..80] of char;
 ResultCopy         : DBIResult;
begin
 {# Table_T it must contain the full Path of D.O.S. of the file}
 Result := False;

 {# To convert of String to Pchar the Destination table}
 StrPCopy(pTable_T, Table_T);

 {# Config and copy the table}
 with Table1 do begin
  try
   Close;
   DataBaseName := Alias_S;
   TableName    := Table_S;
   TableType    := ttDefault;
   StrPCopy(pTable_S, TableName);
   Open;

   ResultCopy   := DbiCopyTable(DBHandle, True, pTable_S, nil, pTable_T);
   Result       := not (ResultCopy <> DBIERR_NONE);
   if Result then Retorno := 'Table - ' + Table_S + ' - it has been successfully copied'
   else Retorno := 'Error produced upon copying table';
  except
   on E: EDBEngineError do Retorno := E.Message;
   on E: Exception      do Retorno := E.Message;
  end;
 end;
end;

procedure TCopia_Dbf.Directory1Change(Sender: TObject);
begin
 EditDirectory.Text := Directory1.Directory;
 if Copy(EditDirectory.Text,Length(EditDirectory.Text),1) <> '\'
 then EditDirectory.Text := EditDirectory.Text + '\';
 EditDirectory.Refresh;
end;

procedure TCopia_Dbf.BBSQLClick(Sender: TObject);
begin
 Ejecutar1Click(nil);
end;

procedure TCopia_Dbf.TN1Click(Sender: TObject);
var Table_S,Index_S : String;
begin

 if TN1.ActivePage = 'Data' then begin

  Table_S := AllTrim(CbTable.Items[CbTable.ItemIndex]);
  Index_S := AllTrim(CbIndex.Items[CbIndex.ItemIndex]);

  with Table1 do begin
   DisableControls;
   Close;
   DatabaseName := EditAlias.Text;

   if (Table_S <> '< All Tables >') and (Length(LTrim(Table_S)) > 0) then
    TableName    := Table_S
   else Exit;

   if (Index_S <> '< Natural Order >') and (Length(LTrim(Index_S)) > 0) then
    IndexName   := Index_S;

   Open;
   EnableControls;
  end;
  DbGrid2.Refresh;
  if not Table1.Eof then EditRegistro.Text := IntToStr(Recno(Table1));
 end;
end;

procedure TCopia_Dbf.TablassinIndices1Click(Sender: TObject);
var
 Contador : Integer;
begin
{To Copy Tables without Indices. Alone the data}
 InicioCopia;

 if CbTable.ItemIndex > 0 then begin
  if Length(AllTrim(Directory1.Directory)) > 2 then begin
   Mensaje('Copying ' + CbTable.Items[CbTable.ItemIndex]);

   if Length(AllTrim(EditFic.Text)) = 0 then EditFic.Text := CbTable.Items[CbTable.ItemIndex];

   if not CopySort(CbAlias.Items[CbAlias.ItemIndex], {Alias Source}
                   CbTable.Items[CbTable.ItemIndex], {Table Source}
                   '',                               {Index Source}
                   Directory1.Directory,             {Alias Target}
                   AllTrim(EditFic.Text),            {Table Target}
                   Retorno,                          {Message of result}
                   TableType_T)                      {Table Type to copy}

   then MessageDlg('Unable to Copy ' + CbTable.Items[ CbTable.ItemIndex ] +
                   '.  Motive: ' +  '. ' + #10 + #10 + Retorno, mtError, [mbOK], 0);

  end else ShowMessage('The destination Directory must be indicated.');

 end else begin
  NTablas := CbTable.Items.Count;
  for Contador := 1 to CbTable.Items.Count - 1 do begin
   Mensaje('Copying ' + CbTable.Items[Contador]);
   Edit2.Text := IntToStr(NTablas - Contador);
   Edit2.Refresh;

   if Length(AllTrim(Directory1.Directory)) > 2 then begin
    if not CopySort(CbAlias.Items[CbAlias.ItemIndex], {Alias Source}
                    CbTable.Items[Contador],          {Table Source}
                    '',                               {Index Source}
                    Directory1.Directory,             {Alias Target}
                    CbTable.Items[Contador],          {Table Target}
                    Retorno,                          {Mensaje de resultado}
                    TableType_T)                      {Tipo de Tabla a copiar}
    then MessageDlg('Impossible to copy ' + CbTable.Items[Contador] +
                      '.  Motive: ' +  '. ' + #10 + #10 + Retorno, mtError, [mbOK], 0);

   end else ShowMessage('The destination Directory must be indicated.');

   Edit2.Text := '';
   Edit2.Refresh;
  end;
  Mensaje('Copying finished.');
 end;
end;

procedure TCopia_Dbf.InicioCopia;
begin
 DbiInit(nil);
 Retorno := ''; {# Messages Ok or Nok returned by the functions}
 Mensaje('');

 {TableType Target}
 if      CbTipoTabla.Text = 'dBase'   then TableType_T := ttDBase
 else if CbTipoTabla.Text = 'Paradox' then TableType_T := ttParadox
 else if CbTipoTabla.Text = 'ASCII'   then TableType_T := ttASCII;
end;

procedure TCopia_Dbf.TablaporunIndice1Click(Sender: TObject);
begin
 (*
 {But forward it is included the original function of the Bde that permits to
  order by a field, but is not used in this example}
 function fDbiSortTable(SrcTbl, DestTbl: TTable; SortField: TField): longint;
 *)

 {To Order Table by an Index}
 InicioCopia;

 Alias_S := AllTrim(CbAlias.Items[CbAlias.ItemIndex]);
 Table_S := AllTrim(CbTable.Items[CbTable.ItemIndex]);
 Index_S := AllTrim(CbIndex.Items[CbIndex.ItemIndex]);

 {# The function of ordering SortTable() returns 1 if has sucess and 0 if defect}
 if not SortTable(Alias_S, Table_S, Index_S, Retorno) then begin
  ShowMessage(Retorno);
  Exit;
 end else begin
  Edit1.Text  := Retorno;
  Edit1.Color := clWhite;
 end;
 Exit;
end;

procedure TCopia_Dbf.FiltroSQL1Click(Sender: TObject);
var
 k : Integer;
begin
 InicioCopia;
 {# To export by the Query SQL Filter}

 {Ctrl. of the existence of the name of the file}
 if Length(AllTrim(EditFic.Text)) = 0 then begin
  ShowMessage('The destination file must be indicated.');
  Exit;
 end;

 if Length(Directory1.Directory) < 3 then begin
  Directory1.SetFocus;
  Exit;
 end;

 {Execute Query}
 BBSQLClick(nil);
 if StrToInt(EditRecordQuery.Text) = 0 then begin
  ShowMessage('The are no records originating from the filter SQL to copy.');
  Exit;
 end;

{To create new table in the indicated directorate}
 with Table2 do begin
  Close;
  DataBaseName := Directory1.Directory;
  TableName    := AllTrim(EditFic.Text);
  TableType    := TableType_T;
  FieldDefs.clear;
  for k := 0 to Query1.FieldDefs.Count-1 do
   FieldDefs.Add(Query1.FieldDefs.Items[k].Name,
                 Query1.FieldDefs.Items[k].DataType,
                 Query1.FieldDefs.Items[k].Size,
                 Query1.FieldDefs.Items[k].Required);
  IndexDefs.Clear;
 end;
 try
  Table2.CreateTable;
 except
  MessageDlg( 'An error has ocurred while creating the table', mtError,[mbCancel], 0 );
 end;

 {# Execute the query copy}
 BMove1.Execute;

 Table2.Open;
 Edit1.Text := 'Process of filter SQL copy ended. ' +
               IntToStr(Table2.RecordCount) +
               ' register copied';
 Table2.Close;
 TN1.ActivePage := 'Filter';
end;

procedure TCopia_Dbf.Tablaordebnada1Click(Sender: TObject);
begin
 {Export - Orderer Table}
 InicioCopia;

 {Ctrl. of the existence of the name of the file}
 if Length(AllTrim(EditFic.Text)) = 0 then begin
  ShowMessage('I need to know the destination file.');
  Exit;
 end;

 {Ctrl. Directory Target}
 EditDirectory.Text := AllTrim(EditDirectory.Text);

 if Length(EditDirectory.Text) < 3 then begin
  Directory1.SetFocus;
  Exit;
 end;

 Alias_S     := AllTrim(CbAlias.Items[CbAlias.ItemIndex]);
 Table_S     := AllTrim(CbTable.Items[CbTable.ItemIndex]);
 Index_S     := AllTrim(CbIndex.Items[CbIndex.ItemIndex]);
 Directory_T := AllTrim(Directory1.Directory);
 Table_T     := AllTrim(EditFic.Text);

 if not CopySort(Alias_S, Table_S, Index_S, Directory_T,
                 Table_T, Retorno, TableType_T) then begin
  ShowMessage(Retorno);
  Exit;
 end else begin