Программа учёта работы склада

while tek<>nil do begin

gotoxy(1,i+9);writeln(line1);

with tek^ do begin

gotoxy(7,i+9);writeln(nam);

gotoxy(16,i+9);writeln(nom);

gotoxy(24,i+9);writeln(dat);

gotoxy(43,i+9);writeln(cen:5:2);

gotoxy(60,i+9);writeln(ocen:5:2);

inc(i);

end;

tek:=tek^.p;

end;

writeln(line2);

writeln('Нажмите любую клавишу');readkey;

end; 

function WideFileTest:boolean;{объявляется процедура обработки ошибок работы с файлами}

var fileError:integer;

begin

fileError:=ioresult;

widefiletest:=true;

if fileError<>0 then begin

widefiletest:=false;

case fileError of {оператор  case позволяет сделать выбор взависимости  от

возвращенного ioresult кода ошибки}

2:writeln('Файл не  найден');

3:writeln('Маршрут  не найден');

4:writeln('Слишком  много открытых файлов');

5:writeln('Доступ к  файлу запрещён');

12:writeln('Некорректный  код доступа к файлам');

else writeln('Неизвестный код ошибки: ',fileError);

end;

Writeln('Нажмите любую клавишу');readkey;

end;

end; 

procedure save;     {объявляем процедуру сохранения  в файл}

var fl:file of newtype;{переменная  для записи данных в файл}

temp:newtype;

flnam:string;   {переменная  для хранения имени файла}

begin

clrscr;

writeln('Сохранение  данных в файл');writeln;  {вывод  сообщения}

tek:=beg;

if tek=nil then begin writeln('Массив данных пуст! Нажмите любую клавишу...');readkey;exit;end;

{если данных  нет, то выход из процедуры}

write('Введите имя файла, в который следует сохранить данные: ');readln(flnam);

{ввод имени  файла}

assign(fl,flnam);{установка  связи с носителем}

{$I-}

rewrite(fl);{открытие  файла для перезаписи}

{$I+}

if not widefiletest then exit;{если функция вернула FALSE, то

файл открыт с ошибками и процедура завершается}

while tek<>nil do begin

       temp.nam:=tek^.nam;

       temp.nom:=tek^.nom;

       temp.dat:=tek^.dat;

       temp.cen:=tek^.cen;

        temp.ocen:=tek^.ocen;

write(fl,temp);{запись  массива данных в файл в  цикле от 1 до n}

tek:=tek^.p;

end;

close(fl);

writeln('Данные записаны  успешно в файл '+flnam);{вывод сообения}

writeln('Нажмите любую  клавишу'); readkey;{ожидание нажатия  клавиши }

end; 

procedure load;{обяъвление  процедуры загрузки данных из  файла}

var fl:file of newtype;{переменная  для записи данных в файл}

temp:newtype;

s,flnam:string;{переменная  для хранения имени файла}

first:boolean;

numnil:integer;

begin

clrscr;

freemem;

writeln('Загрузка данных из файла');writeln;{вывод сообщения}

write('Введите имя  файла, из которого следует  загрузить данные: ');readln(flnam);

if length(flnam)=0 then

begin

writeln('Ошибка! Нажмите Enter');

readln;

exit

end;

assign(fl,flnam);{установка  связи с носителем}

{$I-}

reset(fl);{открытие  файла для чтения}

{$I+}

if not widefiletest then exit;{если функция вернула FALSE, то

файл открыт с  ошибками и процедура завершается}

{читаем файл  в основной массив}

first:=true;

while not eof(fl) do begin  {читаем файл в основной массив}

if first then

   begin

   new(beg);

   tek:=beg;

   read(fl,temp);

         tek^.nam:=temp.nam;

       tek^.nom:=temp.nom;

       tek^.dat:=temp.dat;

       tek^.cen:=temp.cen;

       tek^.ocen:=temp.ocen;

   tek^.p:=nil;

   first:=false;

   end else begin

   new(newp);

   read(fl,temp);

         newp^.nam:=temp.nam;

       newp^.nom:=temp.nom;

       newp^.dat:=temp.dat;

       newp^.cen:=temp.cen;

       newp^.ocen:=temp.ocen;

   newp^.p:=nil;

   tek^.p:=newp;

   tek:=newp;

   end;

end;{while}

close(fl);{закрываем файл}

writeln('Данные загружены  успешно из файла '+flnam+'. Нажмите  любую клавишу');

readkey;

end; 

        {объявляем процедуру сортировки}

procedure sort;

label m1;

var

b,p:ptr;

nam_b:string;

nom_b:string;

dat_b: string;

ocen_b,cen_b:real;

fl:boolean;

f:integer;

begin

    clrscr;

    f:=0;

    p:=beg;

    while p<>nil do

      begin

        inc(f);

        p:=p^.p;

      end;

    if f=0 then

      begin

        write('Невозможно произвести сортировку, т.к. нет данных!');

        readkey;

      exit;

      end;

      m1:

      fl:=false;

      p:=beg;

    while p^.p<>nil do begin

       b:=p^.p;

       if p^.ocen>b^.Ocen then begin

          nam_b:=b^.nam;

          nom_b:=b^.nom;

          dat_b:=b^.dat;

          cen_b:=b^.cen;

          ocen_b:=b^.ocen; 

          b^.nam:=p^.nam;

          b^.nom:=p^.nom;

          b^.dat:=p^.dat;

          b^.cen:=p^.cen;

          b^.ocen:=p^.ocen; 

          p^.nam:=nam_b;

          p^.nom:=nom_b;

          p^.dat:=dat_b;

          p^.cen:=cen_b;

          p^.ocen:=ocen_b; 

          fl:=true;

       end;

       p:=p^.p;

    end;

    if fl then goto m1;

    writeln('Сортировка обменом исходных данных завершена');

    writeln('Записи  в списке отсортированы относительно  поля (итог)');

    writeln('Нажмите ENTER');

     readln;

    out;

    {RisMenu;}

end; 
 
 

procedure diag;   {объявляем процедуру прорисовки диаграммы}

var yy,xx,dx:word;

y:integer;

cena,maxy:real;{координаты вывода}

grd,grm,ec:integer; {служебные  переменные инициализации графического  режима}

ib:string;{строка для  вывода надписей}

lkey:char;      {переменная для считывания нажатой клавиши}

begin

clrscr;writeln('Построение  диаграммы');writeln;{вывод сообщений}

if n<=0 then begin writeln('Массив данных пуст! Нажмите любую клавишу...');readkey;exit;end;

n:=0;

maxy:=0; 

tek:=beg;

while tek<>nil do begin

if maxy<tek^.ocen then

maxy:=tek^.ocen;

n:=n+1;

tek:=tek^.p;

end;

xx:=40;{начало просиросовки  графика по оси Х}

DX:=round(560/n);{считаем  приращение по оси Х}

grd:=0;

InitGraph(grd,grm,'');{запускаем  графический режим}

ec:=graphresult;{функция  возвращает код ошибки инициализации}

if ec<>0 then begin{если  не 0,то вывод сообщения об ошибке  и выход}

textattr:=16*4+15;

writeln('ОШИБКА ГРАФИЧЕСКОГО  РЕЖИМА');

WRITELN(GRAPHERRORMSG(EC),'=',ec);

textattr:=16*0+15;

readkey;

exit;end;

y:=getmaxy;

cena:=(y-100)/(maxy);

tek:=beg;{координата  максимального вывода}

    while tek<>nil do begin {цикл от 1 до n - число элементов  массива}

    Setcolor(10);{устанавливаем  цвет линий и текста}

   Rectangle(xx+2,round(y-60-cena*tek^.ocen),xx+dx-2,getmaxy-60);

   setfillstyle(slashfill,2);

    bar(xx+2,round(y-60-cena*tek^.ocen),xx+dx-2,getmaxy-60);

    {----Насечки на оси-----}

    SetColor(15);

    Line(xx,GetMaxy-63,xx,GetMaxy-57);

    settextstyle(defaultfont,0,1);{определяем положение текста на экране}

    Outtextxy(xx+2,Getmaxy-55,tek^.nam);{выводим текст}

    str(tek^.ocen:7:2,ib);

    outtextxy(xx+2,round(y-cena*tek^.ocen)-10,ib);

    xx:=xx+DX; {увеличиваем Х}

    tek:=tek^.p;

    end;

         {ось Х....}

  Line(xx,GetMaxy-63,xx,GetMaxy-57);

  Line(40,Getmaxy-60,Getmaxx-40,Getmaxy-60); 

  Settextjustify(centertext,centertext);{устанавливаем положение текста относительно координат вывода}

  settextstyle(defaultfont,0,1);{выбираем параметры шрифта}

   setcolor(13);

  Outtextxy(getmaxx div 2,Getmaxy-(getmaxy-10) ,'diag');

  settextstyle(defaultfont,horizdir,1);

  SetColor(15);

  Outtextxy(getmaxx div 2,Getmaxy-25,'press key');

  Readkey;

  closegraph ;  {покидаем  графический режим}

end; 

begin          {начало программы}

clrscr;

gotoxy(15,10);writeln('                 Вариант 8');

gotoxy(15,12);writeln('Программа  учета работы склада');

gotoxy(15,15);writeln('      Нажмите любую клавишу');readkey;

go:=true;

repeat

clrscr;

menu;       {выводим меню}

key:=readkey;  {читаем нажатую клавишу}

if key=#0 then key:=readkey;

case key of

#59:vvod;

#60:addarray;

#61:del;

#62:find;

#63:out;

#64:save;

#65:load;

#66:diag;

#67:sort;

#68:go:=false;

else{или выводим  сообщение об ошибке}

begin writeln('Нажата  неверная клавиша');readkey;end; end;

until not go;

clrscr;

textattr:=16*0+7; {конец программы}

freemem;

clrscr;

end. 
 
 
 
 

 

  
 
 
 
 
 

Приложение 3