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.