Ferramentas de Usuário

Ferramentas de Site


dev_geral:pascal:trabalhar_com_regs_fichs

Como trabalhar com registos e ficheiros - Demo

Fica aqui um programa de demonstração, com o funcionamento básico de ficheiros binários baseados em Records. Com isto, é fácil ver como se cria uma aplicação de bases de dados em Pascal: Não se pretende com isto dar rotinas prontas para fazer o trabalho, mas sim mostrar como as fazer, passo a passo, de modo a que o leitor possa criar as suas proprias rotinas: ;-)

{$MODE Delphi}
program RecordFileSample;
 
{$APPTYPE CONSOLE}
 
(******************************************************************************)
(* Este módulo pretende mostrar o funcionamento base de um programa com recurso
   a uma base de dados em ficheiro binário sequencial.                        *)
(******************************************************************************)
 
uses
  Crt,SysUtils;
 
type
    // Definição dos campos da base de dados
    TDB=record
      Nome:String[200];
      Telemovel:String[15];
      EMail:String[150];
    end;
 
var
   db:File Of TDB;  // Variável de ficheiro
   reg:TDB;         // Variável de conteúdo
 
 
{ Rotinas de Apoio, independentes do funcionamento com ficheiros }
{ Apenas para facilitar o design do Interface                    }
 
procedure WriteXY(Texto:String; X,Y: Byte);
// Escreve uma string no local indicado por X e Y
begin
     GotoXY(X,Y);
     Write(Texto);
end;
 
function ReadXY(X,Y: Byte):String;
// Lê uma string no local indicado por X e Y
begin
     GotoXY(X,Y);
     ReadLn(Result);
end;
 
 
 
 
{ Rotinas do Menu, para consulta, procura, adição e estatística de dados no ficheiro }
 
procedure Consultar;
// Consulta os dados do ficheiro
var
   op:char;
   NumReg:Word;
begin
     // Prepara o Interface
     ClrScr;
     WriteXY('Consulta de registos: ',4,1);
     WriteXY('============================================',4,2);
     WriteXY('Nome.......: ',4,4);
     WriteXY('Telem¢vel..: ',4,6);
     WriteXY('E-Mail... .: ',4,8);
     WriteXY('============================================',4,11);
     WriteXY(' < - Anterior    > - Seguinte    ESC - Menu ',4,12);
 
     // Abre o ficheiro
     Reset(db);
 
     // Verifica se há registos activos
     if FileSize(db)=0
        then begin
                  TextColor(LightRed+Blink);
                  WriteXY('Não há registos para consultar. . .',27,1);
                  TextColor(7);
                  Sleep(2000);
                  // Sai do "Consultar"
                  Exit;
             end;
 
     // Primeiro registo a mostrar
     NumReg:=0;
     repeat
           // Lê o registo actual
           Seek(db,NumReg);
           Read(db,reg);
 
           // Mostra os detalhes do registo
           with reg do
                begin
                     WriteXY(Nome,17,4); ClrEol; // O ClrEol apaga qualquer caracter existente de outro registo anterior
                     WriteXY(Telemovel,17,6); ClrEol;
                     WriteXY(Email,17,8); ClrEol;
                end;
 
           // Lê a opção
           repeat
                 op:=UpCase(Readkey);
           until op in [#27,#0];
           if op=#0 then case readkey of
                              // Left Arrow
                              #75:if NumReg>0
                                     then Dec(NumReg)
                                     else NumReg:=FileSize(db)-1;
                              // Right Arrow
                              #77:if NumReg<FileSize(db)-1
                                     then Inc(NumReg)
                                     else NumReg:=0;
                         end;
     until op=#27;  // ESC termina
 
     // Fecha o ficheiro
     Close(db);
end;
 
procedure Procurar;
// Procura o primeiro registo onde seja encontrado o texto indicado
var
   s:String;
   NumReg:Word;
   Found:Boolean;
begin
     // Prepara o Interface
     clrscr;
     WriteXY('Procurar por: ',4,1);
     WriteXY('============================================',4,2);
     WriteXY('Nome.......: ',4,4);
     WriteXY('Telemovel..: ',4,6);
     WriteXY('E-Mail.....: ',4,8);
 
     // Lê o texto de pesquisa
     s:=ReadXY(18,1);
 
     // Abre o ficheiro
     Reset(db);
 
     // Pesquisa o ficheiro
     Found:=False;
     for NumReg:=0 to FileSize(db)-1 do
         begin
              Seek(db,NumReg);
              Read(db,Reg);
              with Reg do
                   if pos(s,Nome+Telemovel+EMail)>0  // Pesquisa em todos os campos
                      then begin
                                Found:=True;
                                Break;  // Se encontrado, termina o ciclo
                           end;
         end;
 
     if Not Found
        then begin
                  // Não foi encontrado o texto em nenhum registo
                  TextColor(LightRed+Blink);
                  WriteXY('Não encontrado. . .',4,10);
                  TextColor(7);
             end
        else with reg do   // Mostra os detalhes do registo encontrado
                  begin
                       WriteXY(Nome,17,4); ClrEol;
                       WriteXY(Telemovel,17,6); ClrEol;
                       WriteXY(Email,17,8); ClrEol;
                  end;
 
     // Fecha o ficheiro
     Close(db);
 
     // Pausa
     WriteXY('Qualquer tecla para voltar ao menu. . .',4,13);
     if readkey=#0 then readkey;
end;
 
procedure Adicionar;
var
   op:char;
begin
     // Abre o ficheiro
     Reset(db);
 
     repeat
           clrscr;
           // Mostra o nº de registo
           WriteXY('Novo Registo: '+IntToStr(FileSize(db)+1),4,1);
           WriteXY('============================================',4,2);
 
           // Mostra o nome dos campos
           WriteXY('Nome.......: ',4,4);
           WriteXY('Telemovel..: ',4,6);
           WriteXY('E-Mail.....: ',4,8);
 
           // Le os valores dos campos
           with reg do
                begin
                     Nome:=ReadXY(17,4);
                     // Se o nome estiver vazio, cancela a inser‡Æo de registo
                     if Nome=''
                        then begin
                                  Close(DB); // Fecha o ficheiro antes de sair permaturamente
                                  Exit;  // Termina o procedimento prematuramente
                             end;
                     Telemovel:=ReadXY(17,6);
                     EMail:=ReadXY(17,8);
                end;
 
           // Pede confirmação antes de gravar o registo
           WriteXY('Confirma [S/N]: ',4,11);
           repeat
                 op:=Upcase(ReadKey);
           until op in ['S','N',#13,#27];
     Until op in ['S',#13];
 
     // Posiciona-se a seguir à ultima posição, grava os dados no ficheiro e sai
     Seek(db,FileSize(db));
     Write(db,reg);
     Close(db);
end;
 
procedure Stats;
begin
     // Prepara o Interface
     clrscr;
     WriteXY('Estatísticas: ',4,1);
     WriteXY('============================================',4,2);
 
     // Abre o ficheiro
     Reset(db);
 
     // Apresenta as estatísticas
     WriteXY('Total de Registos: '+IntToStr(FileSize(db)),4,4);
 
     // Fecha o ficheiro
     Close(db);
 
     // Pausa
     WriteXY('Qualquer tecla para voltar ao menu. . .',4,7);
     if readkey=#0 then readkey;
end;
 
procedure MainMenu;
var
   op:char;
begin
     repeat
           // Mostra as opções
           ClrScr;
           WriteXY('Agenda',4,2);
           WriteXY('C - Consultar',4,4);
           WriteXY('P - Procurar',4,5);
           WriteXY('A - Adicionar',4,6);
           WriteXY('S - Estatisticas',4,7);
           WriteXY('T - Terminar',4,8);
 
           WriteXY('Opcao: ',4,10);
 
           // Lê a escolha
           repeat
                 op:=UpCase(ReadKey)
           until op in ['C','P','A','S','T',#13,#27];
 
           // Executa a opção
           case op of
                'C',#13:Consultar;
                'P':Procurar;
                'A':Adicionar;
                'S':Stats;
           end;
     until op in ['T',#27];
end;
 
begin
    // Prepara o ficheiro de base de dados
    Assign(db,ChangeFileExt(ParamStr(0),'.dat'));
    {$i-}
    Reset(db);
    {$i+}
    if IOResult<>0 then ReWrite(db);
    Close(db);
 
    // Executa o menu
    MainMenu;
end.
Tópico de discussão no fórum: DEMO - Como trabalhar com registos e ficheiros
dev_geral/pascal/trabalhar_com_regs_fichs.txt · Última modificação em: 2018/05/14 21:37 (edição externa)