Jump to content

DEMO - Como trabalhar com registos e ficheiros


nunopicado
 Share

Recommended Posts

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:  😉

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.

"A humanidade está a perder os seus génios... Aristóteles morreu, Newton já lá está, Einstein finou-se, e eu hoje não me estou a sentir bem!"

> Não esclareço dúvidas por PM: Indica a tua dúvida no quadro correcto do forum.

Link to comment
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
 Share

×
×
  • Create New...

Important Information

By using this site you accept our Terms of Use and Privacy Policy. We have placed cookies on your device to help make this website better. You can adjust your cookie settings, otherwise we'll assume you're okay to continue.