cp_s22en.pas

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

  Edit1.Text  := Retorno;
  Edit1.Color := clWhite;
 end;
end;

procedure TCopia_Dbf.TablasIndices1Click(Sender: TObject);
var
 Contador : Integer;
begin
 {To Copy complete Tables. dbf + mdx}
 InicioCopia;

 if CbTable.ItemIndex > 0 then begin
  {Copy an table}
  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 CopyTableFull(CbAlias.Items[CbAlias.ItemIndex],      {Alias Source}
                         CbTable.Items[CbTable.ItemIndex],      {Table Source}
                         EditDirectory.Text + AllTrim(EditFic.Text),{Alias + Table Target}
                         Retorno)                               {Message of result}
    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 CopyTableFull(CbAlias.Items[CbALias.ItemIndex],
                         CbTable.Items[Contador],
                         EditDirectory.Text + CbTable.Items[Contador],
                         Retorno)
    then MessageDlg('Impossible to copy ' + CbTable.Items[ CbTable.ItemIndex ] +
                    '.  Motive: ' +  '. ' + #10 + #10 + Retorno, mtError, [mbOK], 0);
   end else ShowMessage('The destination Directory must be indicated.');
  end;

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

end;

procedure TCopia_Dbf.Ejecutar1Click(Sender: TObject);
begin
  try
   Screen.Cursor := crHourglass;
   if Query1.Active then Query1.Close;
   Query1.DatabaseName := AllTrim(CbAlias.Items[CbAlias.ItemIndex]);
   Query1.SQL.clear;
   Query1.SQL.Add(Memo1.Text);
   Query1.Active := True;
   Screen.Cursor := crDefault;

   if Query1.Active then begin
    { If the query didn't return any records, there's no point in
    displaying the form.  In that event, raise an exception. }
    if Query1.RecordCount < 1 then
     ShowMessage('There is no data for the filter selected.');
   end;
  finally
   Screen.Cursor := crDefault;
  end;
 EditRecordQuery.Text := IntToStr(Query1.RecordCount);
 TN1.ActivePage := 'Query';
end;

procedure TCopia_Dbf.Salir1Click(Sender: TObject);
begin
 Close;
end;

procedure TCopia_Dbf.Timer1Timer(Sender: TObject);
var
 InformacionSistema: SYSInfo;
 InformacionConfiguracion: SYSConfig;
begin
 {Procedure originating from the book of Fernando Charte, advanced Programming
  with Delphi 2}

 {We obtain updated information }
 DbiGetSysInfo(InformacionSistema);
 DbiGetSysConfig(InformacionConfiguracion);

 {and we show it in the controls disposed in the chip for such end}
 with InformacionSistema do begin
  Buffer.Text        := IntToStr(iBufferSpace);
  Heap.Text          := IntToStr(iHeapSpace);
  Controladores.Text := IntToStr(iDrivers);
  Clientes.Text      := IntToStr(iClients);
  Sesiones.Text      := IntToStr(iSessions);
  BasesDatos.Text    := IntToStr(iDatabases);
  Cursores.Text      := IntToStr(iCursors);
 end;

 with InformacionConfiguracion do begin
  if bLocalShare then Compartir.Text := 'YES' else Compartir.Text := 'NO';

  TipoRed.Text              := szNetType;
  NombreUsuario.Text        := szUserName;
  ArchivoConfiguracion.Text := szIniFile;
  ControladorLenguaje.Text  := szLangDriver;
 end;
end;

procedure TCopia_Dbf.BitBtn1Click(Sender: TObject);
begin
 DbiInit(nil); {Init BDE}
end;


procedure TCopia_Dbf.BitBtn2Click(Sender: TObject);
begin
 DbiExit; {Closed BDE}
end;

procedure TCopia_Dbf.CBIndexChange(Sender: TObject);
function BoolVal(InBool: Boolean): String;
  begin
    if InBool = True then Result:= 'True'
    else Result:= 'False';
  end;

var
 IndexDesc : IDXDesc;
 KeyArray  : String;
 x         : Integer;
begin
 Table1.Open;
 EditIndex.Text := CbIndex.Items[CbIndex.ItemIndex];
 {To obtain the data related to each one from the index}
 if EditIndex.Text <> '< Natural Order >' then begin
  Table1.IndexName := EditIndex.Text;
  DbiGetIndexDesc(Table1.Handle,0,IndexDesc);
  IndexInfo.Clear;
  IndexInfo.Items.Add('Key Expression : ' + IndexDesc.szKeyExp);
  IndexInfo.Items.Add('Index Name : ' + IndexDesc.szname);
  IndexInfo.Items.Add('Tag Name (dBASE) : ' + IndexDesc.szTagName);
  IndexInfo.Items.Add('Index Format : ' + IndexDesc.szformat);
  IndexInfo.Items.Add('Primary : ' + BoolVal(IndexDesc.bPrimary));
  IndexInfo.Items.Add('Descending : ' + BoolVal(IndexDesc.bDescending));
  IndexInfo.Items.Add('Maintained : ' + BoolVal(IndexDesc.bMaintained));
  IndexInfo.Items.Add('Subset : ' + BoolVal(IndexDesc.bSubset));
  IndexInfo.Items.Add('ExpIdx : ' + BoolVal(IndexDesc.bExpIdx));
  IndexInfo.Items.Add('Fields In Key : ' + IntToStr(IndexDesc.iFldsInKey));
  IndexInfo.Items.Add('Key Length : ' + IntToStr(IndexDesc.iKeyLen));
  IndexInfo.Items.Add('Out of Date : ' + BoolVal(IndexDesc.bOutofDate));
  IndexInfo.Items.Add('Key Expression Type : ' + IntToStr(IndexDesc.iKeyExpType));
  KeyArray := '';
  for x:= 0 to IndexDesc.iFldsInKey -1 do
    KeyArray := KeyArray + IntToStr(IndexDesc.aiKeyFld[x]) + ', ';
  IndexInfo.Items.Add('Field Numbers used in Key : ' + KeyArray);
  IndexInfo.Items.Add('Key Condition : ' + IndexDesc.szKeyCond);

  IndexInfo.Items.Add('Case Insensitive : ' + BoolVal(IndexDesc.bCaseInsensitive));
  IndexInfo.Items.Add('iBlockSize : ' + IntToStr(IndexDesc.iBlockSize));
  IndexInfo.Items.Add('iRestrNum : ' + IntToStr(IndexDesc.iRestrNum));
  IndexInfo.Text := 'Key Expression : ' + IndexDesc.szKeyExp;
 end;
 Table1.Close;
end;

procedure TCopia_Dbf.Filtros1Click(Sender: TObject);
begin
 TN1.ActivePage := 'Filter';
end;

procedure TCopia_Dbf.Sql1Click(Sender: TObject);
begin
 TN1.ActivePage := 'Data';
end;

procedure TCopia_Dbf.Query2Click(Sender: TObject);
begin
 TN1.ActivePage := 'Query';
end;

procedure TCopia_Dbf.Estructura1Click(Sender: TObject);
begin
 TN1.ActivePage := 'Bde';
end;

procedure TCopia_Dbf.Explorer1Click(Sender: TObject);
begin
 TN1.ActivePage := 'Explorer';
end;

procedure TCopia_Dbf.Indexar1Click(Sender: TObject);
var
 Contador, NTablas : Integer;
begin
 TN1.ActivePage := 'Filter';

 if CbTable.Items.Count = 1 then Exit; {There is no tables for reindex}

 if (CbTable.Items[CbTable.ItemIndex] <> '< All Tables >') then begin {Index an Table alone}
  Retorno := '';
  Table1.Close;
  Table1.DataBaseName := CbAlias.Items[CbAlias.ItemIndex];
  Table1.TableName    := CbTable.Items[CbTable.ItemIndex];
  Table1.Exclusive    := True;
  Table1.Open;
  Edit1.Text          := ' Indexanding the Tabla ' + Table1.TableName;
  Edit1.Refresh;

  if not fDbiRegenIndexes(Table1, Retorno) then ShowMessage(Retorno);

 end else begin {Index all tables}
  NTablas             := cbTable.Items.Count;
  for Contador := 1 to NTablas - 1 do begin
   Table1.Close;
   Table1.DataBaseName := CbAlias.Items[CbAlias.ItemIndex];
   Table1.TableName    := CbTable.Items[Contador];
   Table1.Exclusive    := True;
   Table1.Open;
   Edit1.Text          := ' Indexanding the Table ' + Table1.TableName;
   Edit2.Text          := IntToStr(Contador);
   Edit1.Refresh;
   Edit2.Refresh;

   if not fDbiRegenIndexes(Table1, Retorno) then ShowMessage(Retorno);

  end;
 end;

 Table1.CLose;
 Table1.Exclusive := False;
 Table1.Open;

 Edit2.Text := '';
 Edit1.Text       := 'Reindex ended.' + IntToStr(Contador) + ' Register index';
end;

procedure TCopia_Dbf.Empaquetar1Click(Sender: TObject);
var
 Contador, NTablas : Integer;
begin
 TN1.ActivePage := 'Filter';

 if CbTable.Items.Count = 1 then Exit; {There is no tables to Packet}

 if (CbTable.Items[CbTable.ItemIndex] <> '< All Tables >') then begin {To Pack an alone Table}
  Retorno := '';
  Table1.Close;
  Table1.DataBaseName := CbAlias.Items[CbAlias.ItemIndex];
  Table1.TableName    := CbTable.Items[CbTable.ItemIndex];
  Table1.Exclusive    := True;
  Table1.Open;
  Edit1.Text          := ' Indexando la Tabla ' + Table1.TableName;
  Edit1.Refresh;

  if not fDbiPackTable(Table1,
                       True,      {Index upon ending, True o False}
                       Retorno) then ShowMessage(Retorno);
  Contador := 1;

 end else begin {Pack all tables}
  NTablas             := cbTable.Items.Count;
  for Contador := 1 to NTablas - 1 do begin
   Table1.Close;
   Table1.DataBaseName := CbAlias.Items[CbAlias.ItemIndex];
   Table1.TableName    := CbTable.Items[Contador];
   Table1.Exclusive    := True;
   Table1.Open;
   Edit1.Text          := ' Packing the Table ' + Table1.TableName;
   Edit2.Text          := IntToStr(Contador);
   Edit1.Refresh;
   Edit2.Refresh;

   if not fDbiPackTable(Table1,
                        True,      {Index upon ending, True o False}
                        Retorno) then ShowMessage(Retorno);

  end;
 end;

 Table1.CLose;
 Table1.Exclusive := False;
 Table1.Open;

 Edit2.Text := '';
 Edit1.Text       := 'Packing finished. ' + IntToStr(Contador) + ' tables Pack';
end;

procedure TCopia_Dbf.Acercade1Click(Sender: TObject);
begin
 ShowMessage('CopySort Version 2.2' + #13 +
             'Delphi 2,3,4' + #13 +
             'Autor: Jose Maria Gias' + #13 +
             '[e-mail]' + #13 +
             'Freeware 26.12.1998');
end;

procedure TCopia_Dbf.DS1DataChange(Sender: TObject; Field: TField);
begin
  if not Table1.Eof then EditRegistro.Text := IntToStr(Recno(Table1));
end;

procedure TCopia_Dbf.CheckBox1Click(Sender: TObject);
begin
 if CheckBox1.Checked then begin
  Query1.RequestLive := True;
  DbGrid1.ReadOnly   := False;
 end else begin
  Query1.RequestLive := False;
  DbGrid1.ReadOnly   := True;
 end;
end;

procedure TCopia_Dbf.EditNearChange(Sender: TObject);
var
 k      : Integer;
 Existe : Boolean;
begin
 Existe := False;
 {Control of the existence of the index of the field}
 for k := 1 to SGrid1.RowCount do
  if UpperCase(AllTrim(sGrid1.Cells[0,k])) = UpperCase(AllTrim(EditIndex.Text)) then
   Existe := True;

 if not Existe then begin
  ShowMessage('In this project can be sought by indices of a field');
  Exit;
 end;

 EditRanStart.Text := '';
 EditRanEnd.Text   := '';

 {Example of applying search brandish accordant we wrote text}
  with Table1 do begin
   CancelRange;
   SetKey;
   FieldByName(AllTrim(EditIndex.Text)).AsString := AllTrim(EditNear.Text);
   GotoNearest;
  end;
end;

procedure TCopia_Dbf.SpeedButton1Click(Sender: TObject);
var
 k      : Integer;
 Existe : Boolean;
 Tipo   : String;
begin
 Existe := False;
 Tipo := '';
 {Control of the existence of the index of the field}
 for k := 1 to SGrid1.RowCount do
  if UpperCase(AllTrim(sGrid1.Cells[0,k])) = UpperCase(AllTrim(EditIndex.Text))
  then begin
   Existe := True;
   Tipo   := sGrid1.Cells[1,k];
  end;

 if not Existe then begin
  ShowMessage('In this project alone can be filter by the index of a field.');
  Exit;
 end;

 {For this application, alone are filtered the String fields}
 if Tipo <> 'String' then begin
  ShowMessage('In this application only the String fields are filtered.');
  Exit;
 end;

 {Control of the text existence to filter}
 if (Length(AllTrim(EditRanStart.Text)) = 0) then begin
  ShowMessage('The text to filter must be indicated.');
 end;

 {Example of applying data filters }
  with Table1 do begin
   CancelRange;

   SetRangeStart;
   FieldByName(AllTrim(EditIndex.Text)).AsString := AllTrim(EditRanStart.Text);

   if (Length(AllTrim(EditRanEnd.Text)) > 0) then begin
    SetRangeEnd;
    FieldByName(AllTrim(EditIndex.Text)).AsString := AllTrim(EditRanEnd.Text);
   end;

   ApplyRange;
  end;
end;

procedure TCopia_Dbf.EditRanStartKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
 EditNear.Text := '';
end;

procedure TCopia_Dbf.PrintSqlClick(Sender: TObject);
var
 k   : Integer;
 f : System.Text;
 Cad : String;
begin

 if not Query1.Active then begin
  ShowMessage('There ar no records to print.');
  Exit;
 end;
 if Query1.RecordCount = 0 then begin
  ShowMessage('There ar no records originating from the SQL filter to copy.');
  Exit;
 end;

 Screen.Cursor            := CrHourGlass;
 Printer.Canvas.Font.Name := 'Courier';
 Printer.Canvas.Font.Size := 9;
 try
  AssignPrn(f);
  Rewrite(f);

  {Headed and Query}
  WriteLn(f,'List of Query') ;
  WriteLn(f,'----------------');
  WriteLn(f,Memo1.Text);
  WriteLn(f,'');

  {Fields and types}
  Cad := '';
  WriteLn(f,'Fields definition');
  WriteLn(f,'--------------------');
  for k := 0 to Query1.FieldDefs.Count-1 do begin
   Cad := AlineaIzqda(IntToStr(k+1),4) + '  ' +
          AlineaIzqda(Query1.FieldDefs.Items[k].Name,20) + '  ' +
          AlineaIzqda(GetFieldType(Query1.FieldDefs.Items[k].DataType),10) + '  ' +
          AllTrim(IntToStr(Query1.FieldDefs.Items[k].Size));
   WriteLn(f,Cad);
  end;
  WriteLn(f,'');

  {Data of the Query}
  WriteLn(f,'Data');
  WriteLn(f,'-----');
  Query1.First;
  Query1.DisableControls;
  while not Query1.Eof do begin
   Cad := '';
   for k := 0 to Query1.FieldDefs.Count - 1 do
    Cad := Cad +  AlineaIzqda(Query1.Fields[k].AsString,
                              Query1.FieldDefs.Items[k].Size) + '