Примечание:
В программе имеются подсказки с правой стороны экрана.
Для программиста:
Программа состоит из множества процедур, которые вызываются из пунктов меню.
Пользовательские типы:
worker – тип динамической памяти типа base;
base – тип – запись(информация о сотрудниках);
sotrud – для работы с файлами типа base.
Используемые процедуры:
Punct1 – по этой процедуре осуществляется занесение служащего в файл.
Punkt2 - удаление записи из списка (увольнение происходит по введённому пользователем регистрационному номеру и Ф.И.О.);
Punkt3 – по этой процедуре можно просмотреть список сотрудников
Punkt4 – процедура упорядочить список
Punkt5 – по этой процедуре можно найти сотрудника
Punkt0 – очистка базы
Punkt6 - выход
Приложение 1
Листинг программы
program imenniniki;
uses crt;
const norm=$74; {цвет не выделенного пункта}
norm1=$8;
sel=$31; {цвет выделенного пункта}
sel1=$15;
type
{-------------------Описание записи----------------}
Worker = ^base;
base=record
rnom:integer; {РЕГИСТРАЦИОННЫЙ НОМЕР}
fam:string[20]; {ФАМИЛИЯ}
name:string[20]; {ИМЯ}
otch:string[20]; {ОТЧЕСТВО}
date:integer; {ДАТА РОЖДЕНИЯ}
month:integer;{МЕСЯЦ РОЖДЕНИЯ}
year:integer; {ГОД РОЖДЕНИЯ}
link:worker;
{--------------------------------------------------}
end;
var
Top,Cur,Next,Prev:Worker;
menu:array[1 .. 11] of string[50]; {Меню}
punkt:integer;
ch,cc:char; {Введенный символ}
sotrud:file of base;
buf,buf1:base; {Два буфер обмена}
k,m:char;
p,n,x,y,i:integer; {}
Procedure FileToDin; {Из файла в динам. память}
begin
top:=nil;
Assign(sotrud,'sotrudn.dat');
{$I-}
Reset(sotrud);
If IOResult<>0 then
begin
rewrite(sotrud);
end
{$I+}
else
if filesize(sotrud)<>0 then
repeat
New(Cur);
Read(sotrud,Cur^);
Cur^.link:=Top;
Top:=Cur;
until eof(sotrud);
close(sotrud);
end;
Procedure DinToFile; {Из дин. памяти в файл}
begin
If Top<>nil then
begin
Assign(sotrud,'sotrudn.dat');
Rewrite(sotrud);
Cur:=Top;
repeat
Write(sotrud,Cur^);
Cur:=Cur^.link;
until Cur=nil;
close(sotrud);
end;
end;
Procedure Menus; {вывод меню на экран}
var
i:integer;
begin
clrscr;
gotoxy(28,wherey); writeln('**************************');
gotoxy(28,wherey); writeln('БАЗА ДАННЫХ ПО СОТРУДНИКАМ');
gotoxy(28,wherey); writeln('**************************');
for i:=p to n do
begin
gotoxy(x,y+i-1);
write ( menu[i] );
end;
{textattr - предопределенная переменная, отвечающая за цвет фона и символов}
textattr:=sel;
gotoxy(x,y+punkt-1);
write( menu[punkt] ); {выделим строку меню}
textattr:=norm;
end;
procedure forsort; {указ меняются местами}
var
rnom1:integer;
fam1:string[20];
name1:string[20];
otch1:string[20];
date1:integer;
month1:integer;
year1:integer;
begin
with Next^ do
begin
rnom1:=rnom;
fam1:=fam;
name1:=name;
otch1:=otch;
date1:=date;
month1:=month;
year1:=year;
end;
Next^.rnom:=Cur^.rnom;
Next^.fam:=Cur^.fam;
Next^.name:=Cur^.name;
Next^.otch:=Cur^.otch;
Next^.date:=Cur^.date;
Next^.month:=Cur^.month;
Next^.year:=Cur^.year;
with Cur^ do
begin
rnom:=rnom1;
fam:=fam1;
name:=name1;
otch:=otch1;
date:=date1;
month:=month1;
year:=year1;
end;
end;
procedure Sortirovka; {Сортировка по фамилии}
begin
Cur:=Top;
while Cur<>nil do
begin
Next:=Cur^.link;
while next<>nil do
begin
if ord(Next^.fam[1]) < ord(Cur^.fam[1]) then
ForSort;
Next:=Next^.link;
end;
cur:=cur^.link;
end;
end;
procedure Uporyad; {Сортировка по дате рождения}
begin
Cur:=Top;
while Cur<>nil do
begin
Next:=Cur^.link;
while next<>nil do
begin
if (Next^.year > Cur^.year) or ((Next^.year = Cur^.year) and (Next^.month > Cur^.month)) or
((Next^.year = Cur^.year) and (Next^.month = Cur^.month) and (Next^.date > Cur^.date)) then
ForSort;
Next:=Next^.link;
end;
cur:=cur^.link;
end;
end;
procedure Position(pos:integer);
var i:integer;
begin
Cur:=Top;
For i:=1 to pos do
if i<>pos then Cur:=Cur^.link;
end;
procedure punkt0; {Очистка базы}
var
cc,k,ch:char;
i:integer;
key:char;
begin
assign(sotrud,'sotrudn.dat');
cc:=chr(13);
{cc:=readkey;}
if cc=chr(13) then
begin
gotoxy(25,10);
writeln('Вы уверены,что хотите удалить базу????');
gotoxy(25,11);
Writeln('Enter-ДА, Esc-НЕТ');
key:=readkey;
if key=chr(13) then
begin
gotoxy(11,4);
write('0%');
gotoxy(63,4);
write('100%');
gotoxy(13,4);
for i:=1 to 20 do
begin
write('=');
delay(500);
end;
for i:=21 to 34 do
begin
write('=');
delay(1300);
end;
for i:=35 to 50 do
begin
write('=');
delay(200);
end;
rewrite(sotrud);
gotoxy(32,18);
write('База очищена');
gotoxy(32,19);
write('Нажмите клавишу Esc');
end;
end;
end;
procedure punkt1; {Новый сотрудник}
var k,ch:char;
begin
clrscr;
gotoxy(12,wherey);writeln('*************************************');
gotoxy(12,wherey);writeln('Добавьте в базу информацию о новом сотруднике - "Enter"');
gotoxy(12,wherey);writeln('*************************************');
ch:=readkey;
if ch<>chr(27) then
begin
new(Cur);
writeln(' Введите информацию');
write('Регистрационный номер: ');
readln(Cur^.rnom);
write('Фамилия: ');
readln(Cur^.fam);
write('Имя: ');
readln(Cur^.name);
write('Отчество: ');
readln(Cur^.otch);
write('Дата рождения в формате ДД: ');
readln(Cur^.date);
write('Месяц рождения в формате ММ: ');
readln(Cur^.month);
write('Год рождения в формате ГГГГ: ');
readln(Cur^.year);
Cur^.link:=Top;
Top:=Cur;
end;
end;
procedure Punkt2; {Уволить}
var
rnom1:integer;
fam1,name1,otch1:string[20];
pos,f:integer;
key:char;
begin
clrscr;
writeln(' *******************************************');
writeln(' Будете удалять сотрудника из базы - "Enter"');
writeln(' *******************************************');
ch:=readkey;
if ch=chr(13) then
begin
clrscr;
if top=nil then
begin
writeln('База пуста');
readln;
end
else
begin
writeln(' **********************');
writeln(' Увольнение сотрудника');
writeln(' **********************');
writeln('Пожалуйста, введите');
writeln('Регистрационный номер увольняемого ');readln(rnom1);
writeln('Фамилия увольняемого: ');readln(fam1);
writeln('Имя увольняемого: ');readln(name1);
writeln('Отчество увольняемого: ');readln(otch1);
Cur:=Top;
pos:=1;
repeat
f:=0;
If Cur^.rnom=rnom1 then
If Cur^.fam=fam1 then
If Cur^.Name=name1 then
if Cur^.otch=otch1 then
begin
writeln('Вы действительно хотите удалить данного сотрудника');
writeln('Enter-ДА, Esc-НЕТ');
key:=readkey;
if key=chr(13) then
begin
if Cur^.link=nil then
begin
dispose(Cur);
f:=1;
end
else
if Cur=Top then
begin
If Top^.link<>nil then
begin
Top:=Top^.link;
dispose(Cur);
f:=1;
end;
end
else
begin
Position(pos-1);
Prev:=Cur;
Cur:=Cur^.link;
Next:=Cur^.link;
Prev^.link:=Next;
Dispose(Cur);
f:=1;
end;
writeln('Сотрудник ' ,fam1,' ',name1,' ',otch1, ' уволен ');
readkey;
end;
end;
Cur:=Cur^.link;
pos:=pos+1;
if (cur=nil) and (f=0) then
begin
WriteLn('Искомый сотрудник не числится');
writeln('Возможно имя или фамилия были введены с маленькой буквы');
Write('Для продолжения нажмите любую клавишу');
readkey;
break;
end;
until f=1;
end;
end;
end;
procedure Punkt3; {Просмотр}
var ch:char;
begin
clrscr;
sortirovka;
writeln(' **********************');
writeln(' Список сотрудников');
writeln(' **********************');
Cur:=Top;
if top=nil then write('ничего нет')
else
repeat
write('Регистрационный номер: ');
writeln(Cur^.rnom);
write('Фамилия: ');
writeln(Cur^.fam);
write('Имя: ');
writeln(Cur^.name);
write('Отчество: ');
writeln(Cur^.otch);
write('Дата рождения: ');
writeln(Cur^.date);
write('Месяц рождения: ');
writeln(Cur^.month);
write('Год рождения: ');
writeln(Cur^.year);
writeLn('**********************************************');
writeln;
Cur:=Cur^.link;
ch:=ReadKey;
if ch<>chr(13) then break;
if cur=nil then
begin
Write('список окончен');
readkey;
break;
end;
until (Cur=nil) or (ch<>chr(13));
end;
procedure Punkt4; {Упорядочить}
var ch:char;
begin
clrscr;
Uporyad;
writeln(' **********************');
writeln(' Список сотрудников');
writeln(' **********************');
Cur:=Top;
if top=nil then write('Файл пуст')
else
repeat
write('Регистрационный номер: ');
writeln(Cur^.rnom);
write('Фамилия: ');
writeln(Cur^.fam);
write('Имя: ');
writeln(Cur^.name);
write('Отчество: ');
writeln(Cur^.otch);
write('Дата рождения: ');
writeln(Cur^.date);
write('Месяц рождения: ');
writeln(Cur^.month);
write('Год рождения: ');
writeln(Cur^.year);
writeLn('**********************************************');
writeln;
Cur:=Cur^.link;
ch:=ReadKey;
if ch<>chr(13) then break;
if cur=nil then
begin
write('список окончен');
readkey;
break;
end;
until (Cur=nil) or (ch<>chr(13));
end;
Procedure Punkt5; {Поиск сотрудника}
var
mon:integer;
f1:text;
fil,s,s1:string;
sch:integer;
search:boolean;
sotr:array[1..10] of base;
begin
clrscr;
gotoxy(33,wherey);
writeln('****************');
gotoxy(33,wherey);
writeln('Выгрузка именинников');
gotoxy(33,wherey);
writeln('****************');
write('Введите месяц ДР: ');
readln(mon);
write('Введите имя файла для выгрузки: ');
readln(fil);
clrscr;
gotoxy(30,wherey);
writeln('********************');
gotoxy(30,wherey);
writeln('Найденные сотрудники');
gotoxy(30,wherey);
writeln('********************');
sch:=0;
i:=0;
search:=false;
Cur:=Top;
while Cur<>nil do
begin
if Cur^.month = mon then
begin
i:=i+1;
sotr[i]:=Cur^;
sch:=sch+1;
search:=true;
end;
Cur:=Cur^.link;
if (search=false) and (Cur=nil) then
writeln('В указанном месяце именинников нет');
end;
if search=true then
begin
writeLn('Искомый месяц: ',mon);
writeLn('');
{Выгружаем список в файл}
Assign(f1,fil);
Rewrite(f1);
for i:=1 to sch do
begin
s:= Sotr[i].fam+' '+Sotr[i].name+' '+Sotr[i].otch+', ';
str(Sotr[i].date,s1);
s:=s+s1;
str(Sotr[i].month,s1);
s:=s+'.' +s1;
str(Sotr[i].year,s1);
s:=s+'.' +s1;
writeln(f1,s);
end;
close(f1);
for i:=1 to sch do
begin
write('Регистрационный номер: ');
writeln(Sotr[i].rnom);
write('Фамилия: ');
writeln(Sotr[i].fam);
write('Имя: ');
writeln(Sotr[i].name);
write('Отчество: ');
writeln(Sotr[i].otch);
write('Дата рождения: ');
writeln(Sotr[i].date);
write('Дата рождения: ');
writeln(Sotr[i].month);
write('Дата рождения: ');
writeln(Sotr[i].year);
writeLn('***************************************************');
ch:=ReadKey;
if ch<>chr(13) then break;
end;
end;
readkey;
end;
Begin
clrscr;
gotoxy(28,wherey);
writeln('**************************');
gotoxy(28,wherey);
writeln('БАЗА ДАННЫХ ПО СОТРУДНИКАМ');
gotoxy(28,wherey);
writeln('**************************');
Top:=nil;
menu[1]:='1. НОВЫЙ СОТРУДНИК';
menu[2]:='2. УВОЛИТЬ СОТРУДНИКА';
menu[3]:='3. ПРОСМОТРЕТЬ СПИСОК';
menu[4]:='4. УПОРЯДОЧИТЬ СПИСОК';
menu[5]:='5. ВЫГРУЗИТЬ ИМЕНИННИКОВ';
menu[6]:='6. ВЫХОД';
menu[8]:= '1. Очистить базу ';
menu[9]:= '2. Продолжить базу';
menu[10]:='3. ВЫХОД';
menu[11]:='';
punkt:=8; x:=30; y:=-2; textattr:=norm;
n:=10; p:=8;
Menus;
repeat
ch:=ReadKey;
if ch=chr(0) then
begin
ch:=ReadKey;
case ch of
chr(80) : { стрелка вниз }
if punkt<=n+1 then
begin
if punkt=10 then
begin
gotoxy(x,y +punkt-1);
write(menu[punkt]);
textattr:= norm;
end;
if punkt=10 then punkt:=7;
gotoxy(x,y+punkt-1);
write(menu[punkt]);
punkt:=punkt+1;
textattr:=sel;
gotoxy(x,y+punkt-1);
write(menu[punkt]);
textattr:= norm;
end;
chr(72) : { стрелка вверх }
if (punkt<=n) and not(punkt<p) then
begin
if punkt=8 then
begin
gotoxy(x,y+punkt-1);
write(menu[punkt]);
textattr:= norm;
end;
if punkt=8 then punkt:=11;
gotoxy(x,y+punkt-1);
write(menu[punkt]);
punkt:=punkt-1;
textattr:=sel;
gotoxy(x,y+punkt-1);
write(menu[punkt]);
textattr:= norm;
end;
end; {case : of }
end
else
if ch=chr(13) then {нажата клавиша <Enter>}
begin
case punkt of
8 : punkt0 ;
9 : ch:=chr(27) ;
10 : exit ; {выход}
end;
end;
until ch= chr(27) ; {27 - код <Esc>}
{clrscr;}
punkt:=1; x:=30; y:=5; textattr:=norm;
n:=6; p:=1;
Menus;
filetodin;
repeat
ch:=ReadKey;
if ch=chr(0) then
begin
ch:=ReadKey;
case ch of
chr(80) : { стрелка вниз }
if punkt<=n+1 then
begin
if punkt=6 then
begin
gotoxy(x,y+punkt-1);
write(menu[punkt]);
textattr:= norm;
end;
if punkt=6 then punkt:=0;
gotoxy(x,y+punkt-1);
write(menu[punkt]);
punkt:=punkt+1;
textattr:=sel;
gotoxy(x,y+punkt-1);
write(menu[punkt]);
textattr:= norm;
end;
chr(72) : { стрелка вверх }
if (punkt<=n) and not(punkt<1) then
begin
if punkt=1 then
begin
gotoxy(x,y+punkt-1);
write(menu[punkt]);
textattr:= norm;
end;
if punkt=1 then punkt:=7;
gotoxy(x,y+punkt-1);
write(menu[punkt]);
punkt:=punkt-1;
textattr:=sel;
gotoxy(x,y+punkt-1);
write(menu[punkt]);
textattr:= norm;
end;
end; {case : of }
end
else
if ch=chr(13) then {нажата клавиша <Enter>}
begin
case punkt of
1 : punkt1 ;
2 : punkt2 ;
3 : punkt3 ;
4 : punkt4 ;
5 : punkt5 ;
6 : ch:=chr(27) ; {выход}
end; {case : of }
Menus;
end;
until ch= chr(27) ; {27 - код <Esc>}
{clrscr;}
dintofile;
End.
Приложение 2
Распечатка структуры базы данных
**********************
Список сотрудников
**********************
Регистрационный номер: 1.
Иванов Петр Семенович
13.05.1960г.
**********************
Регистрационный номер: 2.
Петрова Светлана Михайловна
21.04.1973г.
**********************
Регистрационный номер: 3.
Сидоров Николай Иванович
17.04.1981г.
**********************
Регистрационный номер: 4.
Николаева Наталья Ивановна
12.10.1981г.
**********************
Регистрационный номер: 5.
Соколова Мария Ивановна
06.12.1973г.
Приложение 3
Распечатку результатов решения задачи по данным контрольного примера
Уволен служащий:
**********************
Регистрационный номер: 3.
Сидоров Николай Иванович
17.04.1981г.
**********************
Регистрационный номер: 4.
Николаева Наталья Ивановна
12.10.1981г.
**********************
Просмотр списка сотрудников по алфавиту:
Регистрационный номер: 1.
Иванов Петр Семенович
13.05.1960г.
**********************
Регистрационный номер: 4.
Николаева Наталья Ивановна
12.10.1981г.
**********************
Регистрационный номер: 2.
Петрова Светлана Михайловна
21.04.1973г.
**********************
Регистрационный номер: 3.
Сидоров Николай Иванович
17.04.1981г.
**********************
Регистрационный номер: 5.
Соколова Мария Ивановна
06.12.1973г.
Список именинников в апреле:
Регистрационный номер: 2.
Петрова Светлана Михайловна
21.04.1973г.
**********************
Регистрационный номер: 3.
Сидоров Николай Иванович
17.04.1981г.
**********************