Var I: byte;
Avtomobile: Avto;
ContinueInput: char;
begin
i:=0;
WriteLn;
repeat
i:= i + 1;
with Avtomobile do
begin
write('Введите Фамилию владельца ',i,' автомобиля: ');
readLn(Famil);
write('Введите Номер квитанции ',i,' автомобиля: ');
readLn(NumberKv);
write('Введите Марку ',i,' автомобиля: ');
readLn(Marka);
write('Введите требуемый ремонт ',i,' автомобиля: ');
readLn(TrebRem);
writeLn('Введите информацию о детали для: ',Marka);
write(' Наименование: ');
readLn(Detal.Naim);
write(' Код: ');
readLn(Detal.Kod);
write(' Количество: ');
readLn(Detal.Kolich);
write(' Стоимость одной детали: ');
readLn(Detal.Stoim);
write('Реестровый номер студента ',Famil,': ');
readLn(ReestrNumber);
end;
Base[i] := Avtomobile;
writeLn('Вводим данные о следующем автомобиле');
writeLn('Если ввод окончен введите ''0''');
readLn(ContinueInput);
until ContinueInput='0';
NumOfRec:= i;
end;
{Процедура вывода базы на экран}
procedure OutBase(const Base:TBaseMass; const NumOfRec:byte);
Var I,j: byte;
begin
writeLn;
if NumOfRec <> 0 then
begin
writeLn('База данных содержит следующие сведения:');
for j:=1 to 79 do
write('=');
writeLn;
writeLn('N п/п':6,'| ','реестр. N |':8, 'Фамилия |':10, 'Квитанция |':8,
'Марка |':10,'Требуемый ремонт |':20,'Наименование детали |':15,'Код |':8,
'Количество |':3,'Стоимость |':8,'Реестровый номер |':5);
for j:=1 to 79 do
write('=');
writeLn;
for i:=1 to NumOfRec do
with Base[i] do
begin
write(i:5,' |');
write(Famil:10,' |');
write(NumberKv:8,' |');
write(Marka:10,' |');
write(TrebRem:20,' |');
write(Detal.Naim:15,' |');
write(Detal.Kod:8,' |');
write(Detal.Kolich:3,' |');
write(Detal.Stoim:8,' |');
write(ReestrNumber:5,' |');
for j:=1 to 79 do
write('=');
writeLn;
end;
end
else
writeLn('БД Пуста');
end;
{Процедура обработки запроса к БД
========================================================================}
Procedure RequestToBase(const Base:TBaseMass; const NumOfRec: byte);
Var I,j: byte;
Vladelec: string[10];
Stoim: Real;
begin
if NumOfRec <> 0 then
begin
writeLn;
writeLn('Обработка запроса: Стоимость ремонта по владельцу');
writeLn;
write('Введите фамилию владельца:');
readln (vladelec);
for i:= 1 to NumOfRec do
with Base[i] do
if (Famil = vladelec) then
begin
write(i:5,' |');
write(Famil:10,' |');
write(Marka:10,' |');
write(TrebRem:10,' |');
Stoim:=Detal.Kolich*Detal.Stoim;
write(Stoim: 8,' |');
for j:=1 to 79 do
write('-');
writeLn;
end;
end
else
writeLn('В базе данных нет записей с владельцем ', vladelec)
end;
{==========================================================================}
{Процедура выводящая главное меню}
Procedure MainMenu;
var PunktOfMenu: byte;
Base: TBaseMass;
NumOfRec : byte;
begin
NumOfRec := 0;
repeat
writeLn;
writeLn('Выберите нужное действие:');
writeLn('1 - Ввод новой БД');
writeLn('2 - Вывод БД');
writeLn('3 - Запрос к БД');
writeLn('4 - Выход');
write('Ваш выбор: ');
readLn(PunktOfMenu);
case PunktOfMenu of
1: InputNewBase(Base, NumOfRec);
2: OutBase(Base, NumOfRec);
3: begin
writeLn('Выберите нужное действие:');
writeLn('1 - Стоимость ремонта по данным владельца');
writeLn('4 - Выход');
write('Ваш выбор: ');
readLn(PunktOfMenu);
case PunktOfMenu of
1: RequestToBase(Base, NumOfRec);
end;
end;
else
if PunktOfMenu<>4 then
writeLn('Введите корректный пункт меню');
end; {конец case}
until PunktOfMenu = 4;
end;
{Главная программа}
begin
MainMenu;
end.
Задание 3. Файлы записного типа. СУБД.
15. В автомастерской ведется реестр поступивших в ремонт автомобилей. В строке реестра автомобилей указаны фамилия владельца, номер квитанции, марка автомобиля, требующийся ремонт, наименование и код детали, необходимой для ремонта, их количество, стоимость одной детали. СУБД должна выдавать следующие сведения:
- список автомобилей заданной марки, находящихся в ремонте;
- по коду детали ее наименование и количество;
- владелец, чей автомобиль имеет наибольшую стоимость ремонта;
+ перечень марок различных автомобилей, находящихся в ремонте;
+ сортировка по отдельным полям.
program subd;
uses crt, windows, sysutils;
type
Avto = Record
Famil: string[10];
number: byte;
marka: string[10];
remont: string[20];
detal : record
naim : string[10];
kod : byte;
kolich : byte;
stoim : real;
end; {STUD}
end; {Student}
TFileRecs = file of avto; {БД}
var f:TFileRecs; {файл с БД}
filePath:string; {путь к файлу с БД}
toDelFile:boolean; {вспомогательная переменная}
{--------------------------------------------------------------}
{процедура формирования одной записи}
procedure addOneRecord(var Rec:Avto);
const Otstup = 20;
begin
WriteLn;
with Rec do
begin
write('Фамилия:':Otstup);
readLn(Famil);
write('номер квитанции:':Otstup);
readLn(number);
write('марка:':Otstup);
readLn(marka);
write('требуемый ремонт:':Otstup);
readLn(remont);
writeLn('Необходимые детали для ремонта:':Otstup);
write('наименование:':Otstup);
readLn(detal.naim);
write('код:':Otstup);
readLn(detal.kod);
write('количество:':Otstup);
readLn(detal.kolich);
write('стоимотсть одно шт:':Otstup);
readLn(detal.stoim);
end;
writeLn;
end;
{--------------------------------------------------------------}
{Процедура ввода базы}
procedure InputBase(var f: TFileRecs);
var i:byte;
caseKey:char;
Rec:avto;
begin
writeLn;
writeLn('Вводите элементы базы данных');
i:=fileSize(f);
repeat
inc(i);
writeLn('Вводите ',i,'-й элемент');
addOneRecord(Rec);
write(f,Rec);
writeLn('Для прекращения ввода нажмите "0"');
readLn(caseKey);
until caseKey='0';
end;
{--------------------------------------------------------------}
{процедура вывода заголовка БД}
procedure Zagolovok (const Otstup,Nf:integer);
var i:integer;
begin
for i:=1 to Otstup*(Nf+1) do
write('=');
writeLn;
write('номер п/п |':Otstup);
write('Фамилия |':Otstup);
write('номер квитанции |':Otstup);
write('марка |':Otstup);
write('ремонт |':Otstup);
write('деталь наименование |':Otstup);
write('код |':Otstup);
write('количество |':Otstup);
write('стоимость |':Otstup);
writeLn;
for i:=1 to Otstup*(Nf+1) do
write('=');
writeLn;
end;
{--------------------------------------------------------------}
{процедура выводящая полоску из знаков "="}
procedure polosa(const Otstup,Nf:integer);
var i:integer;
begin
for i:=1 to Otstup*(Nf+1) do
write('=');
writeLn;
end;
{--------------------------------------------------------------}
{процедура вывода одной записи на экран}
procedure outOneRecord(const Rec:avto;const i:integer);
const Otstup1 = 18;
begin
with Rec do
begin
write(i:Otstup1, ' |');
write(famil:Otstup1, ' |');
write(number:Otstup1, ' |');
write(marka:Otstup1, ' |');
write(remont:Otstup1, ' |');
write(detal.naim:Otstup1, ' |');
write(detal.kod:Otstup1, ' |');
write(detal.kolich:Otstup1, ' |');
write(detal.stoim:Otstup1, ' |');
writeLn;
end;
end;
{--------------------------------------------------------------}
{процедура вывода БД на экран}
procedure OutBase(var f:TFileRecs);
var Rec:avto;
i:integer;
begin
Zagolovok(20,13);
reset(f);
while not EOF(f) do
begin
i:=filePos(f)+1;
read(f,Rec);
outOneRecord(Rec,i);
end;
polosa(20,13);
end;
{--------------------------------------------------------------}
{процедура удаления одной записи с номером i}
procedure DelRec(var f:TFileRecs; const i:integer);
var Rec:avto;
begin
seek(f,i);
while not EOF(f) do
begin
read(f,Rec);
seek(f,filepos(f)-2);
write(f,Rec);
seek(f,filepos(f)+1);
end;
seek(f,fileSize(f)-1);
truncate(f);
seek(f,i-1);
end;
{--------------------------------------------------------------}
{процедура корректировки одной записи}
procedure ChangeRec(var f:TFileRecs; const i:integer);
var Rec:avto;
begin
writeLn('Давайте изменим эту запись полностью:');
addOneRecord(Rec);
seek(f,i-1);
write(f,Rec);
seek(f,i-1);
end;
{--------------------------------------------------------------}
{Процедура удаления и корректировки записей}
procedure DelCorrBase(var f:TFileRecs);
var Rec:avto;
i:integer;
caseKey:char;
begin
repeat
OutBase(f);
writeLn('Выберите номер записи, для редактирования');
writeLn('"0" - возврат в предыдущее меню');
readln(i);
while (i>filesize(f)) or (i<0) do
begin
writeLn('нет такого номера!');
writeLn('Выберите номер записи, для редактирования');
writeLn('"0" - возврат в предыдущее меню');
readln(i);
end;
if i<>0 then
begin
seek(f,i-1);
read(f,Rec);
Zagolovok(20,13);
outOneRecord(Rec,i);
polosa(20,13);
writeLn('Для удаления записи введите "9"');
writeLn('Для корректировки введите "1"');
writeLn('Для возврата в предыдущее меню введите "0"');
writeLn('Для продолжения редактирования БД введите иной символ');
writeLn('Ваш выбор:');
readLn(caseKey);
case caseKey of
'9': DelRec(f,i);
'1': ChangeRec(f,i);
end;
end
else
caseKey:='0';
until caseKey='0';
end;
{--------------------------------------------------------------}
{запросы к БД
caseRequest - номер запроса}
procedure request(var f:TFileRecs; const caseRequest:byte);
var Rec:avto;
k:integer;
prediction:boolean;
needmarka:string[10];
needkoddet:byte;
needstoim: Real;
begin
reset(f);
k:=0;
case caseRequest of
1: begin {список авто заданной марки находящихся на ремонте}
writeLn('введите марку авто:');
ReadLn(needmarka);
end;
2: begin {владелеч чей авто имее наибольшую стоимость}
needstoim:=0;
while not EOF(f) do
begin
read(f,Rec);
with Rec do
begin
if (rec.detal.kolich*rec.detal.stoim)>needstoim then
needstoim :=rec.detal.kolich*rec.detal.stoim;
end;
end;
end;
3: begin {наименование и количество деталей по коду}
writeLn('введите код детали:');
ReadLn(needkoddet);
end;
end;
reset(f);
Zagolovok(20,13);
while not EOF(f) do
begin
read(f,Rec);
case caseRequest of
1: prediction:=(needmarka=rec.marka);
2: prediction:=(needstoim=rec.detal.kolich*rec.detal.stoim);
3: prediction:=(needkoddet=rec.detal.kod);
end;
if prediction then
begin
inc(k);
outOneRecord(Rec,k);
end;
end;
polosa(20,13);
if k>0 then
writeLn('вывод окончен')
else
writeLn('БД не содержит сведений, удовлетворяющих запросу');
end;
{--------------------------------------------------------------}
{подменю запросов к БД}
procedure SubMenuRequest(var f:TFileRecs);
var keyCase:char;
begin
repeat
writeLn;
writeLn('Выберите запрос к БД');
writeLn('1 - список автомобилей заданной марки, находящихся на ремонте');
writeLn('2 - владелец, чей авто имеет наибольшую стоимость');
writeLn('3 - перечень марок различных авто, находящихся на ремонте');
writeLn('4 - по коду детали ее наименование и количество ');
writeLn('5 - назад в главное меню');
readLn(keyCase);
case keyCase of
'1': request(f,1);
'2': request(f,2);
'3': request(f,3);
else
if keyCase<>'5' then
writeLn('Выберите, пожалуйста, корректный пункт меню');
end;
until keyCase='5';
writeLn;
end;
{--------------------------------------------------------------}
{Добавление записи к БД}
procedure AddRecord(var f:TFileRecs);
var Rec:avto;
caseKey:char;
begin
seek(f,filesize(f));
repeat
addOneRecord(Rec);
write(f,Rec);
writeLn('для добавления ещё одной записи введите "1"');
readLn(caseKey);
until caseKey <> '1';
end;
{--------------------------------------------------------------}
{процедура выводящая главное меню программы}
function MainMenuTitle:char;
var PunktOfMenu: char;
begin
writeLn;
writeLn('Выберите нужное действие:');
writeLn('1 - Вывод БД');
writeLn('2 - Корректировка и удаление записей');
writeLn('3 - Подменю запросов к БД');
writeLn('4 - Добавление новых элементов в БД');
writeLn('5 - Выход');
write('Ваш выбор:');
readLn(PunktOfMenu);
MainMenuTitle := PunktOfMenu;
end;
{--------------------------------------------------------------}
{Процедура вывода запроса пункта главного меню}
procedure MainMenuCase(var f:TFileRecs);
var PunktOfMenu:char;
begin
repeat
PunktOfMenu:=MainMenuTitle;
case PunktOfMenu of
'1': OutBase(f);
'2': DelCorrBase(f);
'3': SubMenuRequest(f);
'4': AddRecord(f);
'5':;
else
writeLn('нет такого пункта меню, введите ещё раз');
end;{case}
until PunktOfMenu='5';
end;
{--------------------------------------------------------------}
{процедура открытия нового файла}
function OpenNewfile(var filePath:string):boolean;
var flag:boolean;
KeyCase:char;
begin
repeat
flag:=TRUE;
writeLn('введите имя файла с которым будем работать');
readLn(filePath);
if FileExists(filePath) then
begin
writeLn('Файл с таким именем ("',filePath,'") уже существует,');
writeLn('Выберите действие:');
writeLn('0 - если Вы его хотите перезаписать');
writeLn('1 - если Вы его хотите открыть');
writeLn('другая клавиша - ввод иного имени');
flag:=TRUE;
assign(f,filePath);
readLn(KeyCase);
case KeyCase of
'1': OpenNewfile:=FALSE;
'0': OpenNewfile:=TRUE;
else
flag:=FALSE;
end; {case}
end
else
OpenNewfile:=TRUE;
until flag;
end;
{==============================================================}
{главная программа}
begin
clrscr;
toDelFile:=OpenNewfile(filePath);
assign(f,filePath);
if toDelFile then
begin
rewrite(f);
InputBase(f);
end
else
reset(f);
MainMenuCase(f);
close(f);
end.