nunopicado Posted March 23, 2012 Report Share Posted March 23, 2012 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 More sharing options...
Recommended Posts
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 accountSign in
Already have an account? Sign in here.
Sign In Now