Pascal и Pervasive

Program BaseData;
uses crt;
label 12;
type
qwerty = record
Name :string;
fam :string;
tel :string;
id :string;
spec :string;
end;
const namebase = 'base.db';
var
fil :file of qwerty;
qwer :qwerty;
otv :char;
poisk:string;
poi :integer;
col :integer;
i,y :integer;
procedure menu;
begin
assign(fil,namebase);
if FileExists(NAMEBASE) then reset(fil)
else rewrite(fil);
writeln('__________________________________________________________');
writeln(' 1. Добавить запись');
writeln(' 2. Обзор всех записей');
writeln(' 3. Быстрый поиск');
writeln(' 4. Расширеный поиск');
writeln(' 5. Удалить запись');
writeln(' 6. Изенить заись');
writeln(' 7. Выход');
write('Выбор: ');readln(otv);
end;
procedure menu_search;
begin
writeln('__________________________________________________________');
writeln(' 1. по имени');
writeln(' 2. по фамилии');
writeln(' 3. по телефону');
writeln(' 4. по профессии');
write('Выбор: ');
readln(poi);
case poi of
1: begin
seek(fil,0);
writeln('поиск о имени');
readln(poisk);
col:=0;
writeln;
while not(eof(fil)) do
begin
read(fil,qwer);
if qwer.name = poisk then
begin
inc(col);
writeln(col,'. Имя: ',qwer.name,' Фамилия: ',qwer.fam,' Телефон: ',qwer.tel,' Професия: ',qwer.spec,' id номер: ',qwer.id);
end;
end;
writeln;
writeln(' кол-во записей = ',col);
end;
2: begin
seek(fil,0);
writeln('Поиск по фамилии');
readln(poisk);
col:=0;
writeln;
while not(eof(fil)) do
begin
read(fil,qwer);
if qwer.fam = poisk then
begin
inc(col);
writeln(col,'. Имя: ',qwer.name,' Фамилия: ',qwer.fam,' Телефон: ',qwer.tel,' Професия: ',qwer.spec,' id номер: ',qwer.id);
 
end;
end;
writeln;
writeln(' кол-во записей = ',col);
end;
3: begin
seek(fil,0);
writeln('Поиск по номеру телефона');
readln(poisk);
col:=0;
writeln;
while not(eof(fil)) do
begin
read(fil,qwer);
if qwer.tel = poisk then
begin
inc(col);
writeln(col,'. Имя: ',qwer.name,' Фамилия: ',qwer.fam,' Телефон: ',qwer.tel,' Професия: ',qwer.spec,' id номер: ',qwer.id);
 
end;
end;
writeln;
writeln(' кол-во записей = ',col);
end;
4: begin
seek(fil,0);
writeln('Поиск по профессии');
readln(poisk);
col:=0;
writeln;
while not(eof(fil)) do
begin
read(fil,qwer);
if qwer.spec = poisk then
begin
inc(col);
writeln(col,'. Имя: ',qwer.name,' Фамилия: ',qwer.fam,' Телефон: ',qwer.tel,' Професия: ',qwer.spec,' id номер: ',qwer.id);
 
end;
end;
writeln;
writeln(' кол-во записей = ',col);
end;
5: begin
seek(fil,0);
writeln('Поиск по id номеру');
readln(poisk);
col:=0;
writeln;
while not(eof(fil)) do
begin
read(fil,qwer);
if qwer.id = poisk then
begin
inc(col);
writeln(col,'. Имя: ',qwer.name,' Фамилия: ',qwer.fam,' Телефон: ',qwer.tel,' Професия: ',qwer.spec,' id номер: ',qwer.id);
 
end;
end;
writeln;
writeln(' кол-во записей = ',col);
end;
end;
end;
procedure files_add;
begin
seek(fil,filesize(fil));
with qwer do
begin
writeln('*****************************************************');
writeln('Введите данные новой записи:');
write('имя ');
readln(name);
write('фамилия ');
readln(fam);
write('телефон ');
readln(tel);
writeln('професия');
readln(spec);
writeln('id номер');
readln(id);
writeln('*****************************************************');
end;
write(fil,qwer);
end;
procedure files_read;
 
begin
seek(fil,0);
col:=0;
writeln;
writeln(' чтение записи из файла ');
while not(eof(fil)) do
begin
inc(col);
read(fil,qwer);
writeln(col,'. Имя: ',qwer.name,' Фамилия: ',qwer.fam,' Телефон: ',qwer.tel,' Професия: ',qwer.spec,' id номер: ',qwer.id);
 
end;
writeln;
writeln(' кол-во записей = ',col);
end;
procedure search;
begin
seek(fil,0);
writeln('Поиск по имени');
readln(poisk);
col:=0;
writeln;
while not(eof(fil)) do
begin
read(fil,qwer);
if qwer.name = poisk then
begin
inc(col);
writeln(col,'. Имя: ',qwer.name,' Фамилия: ',qwer.fam,' Телефон: ',qwer.tel,' Професия: ',qwer.spec,' id номер: ',qwer.id);
 
end;
end;
writeln;
writeln(' кол-во записей = ',col);
end;
 
Procedure del_record;
var NumRec:integer;
IOresult: integer;
begin
Assign(fil,namebase);
{$I-}
reset(fil);
{$I }
If IOresult=1 then
begin
writeln('Такого файла данных не существует');
end
else
writeln('Введите номер удаляемой записи');
Read(NumRec);
begin
if NumRec  >FileSize(fil) then
begin
writeln('Такой записи не существует');
end
else
begin
Seek(fil,FileSize(fil)-1);
read(fil,qwer);
Seek(Fil,NumRec-1);
write(fil,qwer);
Seek(fil,FileSize(fil)-1);
truncate(fil);
Writeln('Запись стерта');
writeln('Файл данных имеет ',FileSize(fil),' записей');
close(fil);
end;
end;
 
end;
 
Procedure Edit_fil;
var
fil :file of qwerty;
qwer :qwerty;
who :string;
found: boolean;
IOresult:integer;
begin
write('Введите фамилию которую вы хотите изменить ');
readln(who);
if who = 'quit' then halt
else
assign(fil,namebase);
{$I-}
reset(Fil);
{$I }
found:=false;
if IOresult=0 then
with qwer do
while Not EOF(Fil) do
begin
read(Fil,qwer);
if fam = who then { нашли такого/ую }
begin
write('Заменить на фамилию: ');
readln(fam);
found:=true;
seek(Fil,FilePos(Fil)-1); { вернуться на 1 позицию обратно, т.е. на позицию того, что надо заменять }
write(fil,qwer);
break; { убрать это, если известно, что таких несколько }
end;
end;
close(fil);
if Not Found
then writeln(Who,' не найден. Ха-ха')
else writeln(Who,' найден и заменен.');
readln;
end;
 
begin
writeln;
writeln(' ***************************************************************');
Writeln(' ******************* База данных КИТБ группа КПО-08 *****************');
writeln(' ***************************************************************');
 
writeln;
 
 
12: menu;
clrscr;
case otv of
'1':files_add;
'2':files_read;
'3':search;
'4':menu_search;
'5':del_record;
'6':Edit_fil;
'7':halt;
end;
goto 12;
close(fil);
end.