Компьютерный форум
Правила
Вернуться   Компьютерный форум > Форум программистов > Языки программирования > Вопросы начинающих программистов
Перезагрузить страницу Вывод на экран данные из картотеки общего пользования
Ответ
 
Опции темы Опции просмотра
  (#1 (permalink)) Старый
Кися Кися вне форума
Новичок
 
Сообщений: 7
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 20.05.2006
По умолчанию Вывод на экран данные из картотеки общего пользования - 30.05.2006, 21:37

Всем привет,мне очень нужна ваша помошь! Вот у4словие задачи.

Пусть дан файл,содержащий сведения о жителях обслужеваемых данной поликлиникой.Сведения содержат следующую информацию:фамилия,имя ,отчество жителя,адрес,место работы,наличия прививки от дифтерии,дату прохождения последней флюрографии.
Вывести на экран и в файл:
Фамилии и адреса тех жильцов,которые не сделали прививку от дифтири;с данными о жильцах у которых на данный момент просроченна дата флюрографии(дата считается просрочена,если с момента прошло больше года).



А вот это ее решение,я немогу в ней разобраться,что мне делать при запуске,выдает меню,но я немогуи найти файлы где храняться данные о пациентах и таким образом немогу вывести на экран что от меня требуют.

Код:
program Agunda; 
uses 
  crt, Dos; 

const 
  days : array [0..6] of String[11] = 
    ('Воскресенье','Понедельник','Вторник', 
     'Среда','Четверг','Пятница', 'Суббота'); 

type 
  tfio = record 
    sname, fname, mname: String[20]; 
  end; 

  tdate = record 
    year : WORD; 
    month : 1..12; 
    day : 1..31; 
  end; 


  tzhitel = record 
    name: tfio; 
    ad, mr: string[20]; 
    privivka: 0..1; 
    date_v : tdate; 
  end; 

var 
  zhitel : tzhitel; 
  f: text; 
  fn: string[40]; 

procedure newfile; 
begin 
  {$I-} 
    rewrite(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Не возможно создать!!! Защита от записи?'); 
    exit; 
  end; 

  writeln('Файл создан'); fn:='ATmp'; 
  close(f); 
end; 

procedure fileopen; 
var f2:text; f2n:string; 
begin 
  write('Имя файла: '); readln(f2n); assign(f2,f2n); 
  {$I-} 
    reset(f2); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Не найден такой файл!'); 
    exit; 
  end; 
  close(f2); 

  assign(f,f2n); 
  writeln('Файл загружен'); fn:=f2n; 
end; 

procedure filesave; 
var f2: text; f2n:string; 
begin 
  {$I-} 
    reset(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Надо сначала создать или открыть файл!'); 
    exit; 
  end; 

  write('Имя файла: '); readln(f2n); assign(f2,f2n); 
  {$I-} 
    rewrite(f2); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Не возможно сохранить!!! Защита от записи?'); 
    exit; 
  end; 
  
  close(f2); erase(f2); 
  close(f); 
  rename(f,f2n); 

  writeln('Файл сохранен');  fn:=f2n; 
end; 

procedure smotret; 
var i,j: byte; fio: string[16]; 
begin 
  {$I-} 
    reset(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Надо сначала создать или открыть файл!'); 
    exit; 
  end; 

  if eof(f) then writeln('Файл пуст'); 
  j:=0; 
  while not eof(f) do 
  begin 
  writeln('Файл данных "',fn, '"',' Записи ':40,j*15+1,'-',(j+1)*15); 
  writeln('+---+------------------+------------------+------------------+---+------------+'); 
  writeln('! № !      ФИО         !     Адрес        !   Место работы   ! П !  Дата флюр !'); 
  writeln('+---+------------------+------------------+------------------+---+------------+'); 
  i:=1; 
  while not eof(f) and (i<=15) do 
      begin 

  with zhitel do 
  begin 
    with name do 
    begin 
      readln(f,sname);readln(f,fname);readln(f,mname); 
      fio:=sname +' '+fname[1]+'.'+mname[1]+'.'; 
      write('є',(j*15+i):2,' є ',fio:16,' є '); 
    end; 
    
    readln(f,ad);fio:=ad; write(fio:16,' є '); 
    readln(f,mr);fio:=mr; write(fio:16,' є '); 
    
    readln(f,privivka); 
    if privivka=1 then write('+',' є ') else write('-',' є '); 
      
    with date_v do 
    begin 
      readln(f,day);readln(f,month);readln(f,year); 
      writeln(day:2,'/', month:2,'/', year:4,' є'); 
    end; 
  end; 
      inc(i); 
     end; 
 writeln('+---+------------------+------------------+------------------+---+------------+'); 
  if not eof(f) then 
   begin writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln;end 
  else inc(j); 

  end; 
  close(f); 
end; 

procedure add; 
var ch: char; 
begin 
  {$I-} 
    append(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Надо сначала создать или открыть файл!'); 
    exit; 
  end; 

 repeat 
  reset(f); 
  if not eof(f) then 
   begin append(f); writeln(f); end 
  else append(f); 
  with zhitel do 
  begin 
    writeln('Информация о жителе':55); 
    with name do 
    begin 
      write('Фамилия: ':40);     readln(sname); writeln(f,sname); 
      write('Имя: ':40);     readln(fname); writeln(f,fname); 
      write('Отчество: ':40);     readln(mname); writeln(f,mname); 
    end; 
    
    write('Адрес: ':40);readln(ad);writeln(f,ad); 
    write('Место работы: ':40);readln(mr);writeln(f,mr); 
    
    write('Прививка (0/1): ':40);readln(privivka);writeln(f,privivka); 
      
    writeln('Дата  флюрографии (ДД ММ ГГГГ): ':55); 
    with date_v do 
    begin 
      write('День: ':40);readln(day);writeln(f,day); 
      write('Месяц: ':40);readln(month);writeln(f,month); 
      write('Год: ':40);readln(year); write(f,year); 
    end; 
  end; 

  write('Добавить еще? (Y/N) ');readln(ch); 
 until UpCase(ch)='N'; 

 close(f); 
end; 

procedure del; 
var 
  i,j,n : integer; 
  f2: text; 
  f2n,s: string; 
  ch:char; 
begin 
  {$I-} 
    reset(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Надо сначала создать или открыть файл!'); 
    exit; 
  end; 

  assign(f2, '~tmp'); 
  {$I-} 
    rewrite(f2); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Не возможно записать!!! Защита от записи?'); 
    exit; 
  end; 

 repeat 
  repeat 
   write('Введите номер = '); readln(n); 
  until (n>0); 

  i:=1; 
  while not eof(f) do 
  begin 
    for j:=1 to 8 do 
      begin readln(f, s); if i<>n then writeln(f2, s);end; 
    readln(f, s); if i<>n then write(f2, s); 
    inc(i); 
    if not eof(f) and ((i<>n) and (n>1) or 
       (i<>2)and(n=1)) then writeln(f2); 
  end; 
  close(f); erase(f); 
  close(f2); rename(f2, fn); 
  assign(f, fn); 
  reset(f); 
  assign(f2, '~tmp'); 
  rewrite(f2); 

  writeln('Удалить еще? (Y/N) ');readln(ch); 
 until UpCase(ch)='N'; 

 close(f);close(f2); 
end; 

procedure reshit1; 
var 
  y, m, d, dow : Word; 
  i,j: word; 
  f2: text; f2n: string; fio:string[48]; 
begin 
  GetDate(y,m,d,dow); 
  WriteLn('Сегодня ', days[dow],', ', 
          m:2, '/', d:2, '/', y:4); 

  {$I-} 
    reset(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Надо сначала создать или открыть файл!'); 
    exit; 
  end; 

  write('Имя файла результатов: '); readln(f2n); assign(f2,f2n); 
  {$I-} 
    rewrite(f2); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Не возможно сохранить!!! Защита от записи?'); 
    exit; 
  end; 

  if eof(f) then writeln('Файл пуст'); 
  j:=0;   i:=1; 
  while not eof(f) do 
  begin 
  writeln('Файл данных "',fn, '"',' Записи ':40,j*15+1,'-',(j+1)*15); 
  writeln(f2,'Файл данных "',fn, '"',' Записи ':40,j*15+1,'-',(j+1)*15); 
  writeln('+---+--------------------------------------------------+----------------------+'); 
  writeln('! № !             Фамилия Имя Отчество                 !         Адрес        !'); 
  writeln('+---+--------------------------------------------------+----------------------+'); 
  writeln(f2,'+---+--------------------------------------------------+----------------------+'); 
  writeln(f2,'! № !             Фамилия Имя Отчество                 !         Адрес        !'); 
  writeln(f2,'+---+--------------------------------------------------+----------------------+'); 
  i:=1; 
  while not eof(f) and (i<=15) do 
      begin 

  with zhitel do 
  begin 
    with name do 
    begin 
      readln(f,sname);readln(f,fname);readln(f,mname); 
    end; 
    
    readln(f,ad); 
    readln(f,mr); 
    
    readln(f,privivka); 
      
    with date_v do 
    begin 
      readln(f,day);readln(f,month);readln(f,year); 
    end; 

    if privivka<>1 then 
    begin 
      fio:=name.sname +' '+name.fname+' '+name.mname; 
      writeln('є',(j*15+i):2,' є ', fio:48,' є ',ad:20,' є'); 
      writeln(f2,'є',(j*15+i):2,' є ', fio:48,' є ',ad:20,' є'); 
          inc(i); 
    end; 
  end; 
      
     end; 
  writeln('+---+--------------------------------------------------+----------------------+'); 
  writeln(f2,'+---+--------------------------------------------------+----------------------+'); 
  if not eof(f) then 
   begin textcolor(red+blink); write('Нажмите ENTER...'); readln;end 
  else inc(j); 

  end; 
  writeln(f2,'Найдено ',(15*(j-1)+i-1),' человек, не сделавших прививку'); 
  close(f); close(f2); 
end; 

procedure reshit2; 
var 
  y, m, d, dow : Word; 
  i,j: word; 
  f2: text; f2n: string; fio:string[48]; 
begin 
  GetDate(y,m,d,dow); 
  WriteLn('Сегодня ', days[dow],', ', 
          m:2, '/', d:2, '/', y:4); 

  {$I-} 
    reset(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Надо сначала создать или открыть файл!'); 
    exit; 
  end; 

  write('Имя файла результатов: '); readln(f2n); assign(f2,f2n); 
  {$I-} 
    rewrite(f2); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Не возможно сохранить!!! Защита от записи?'); 
    exit; 
  end; 

  if eof(f) then writeln('Файл пуст'); 
  j:=0;      i:=1; 
  while not eof(f) do 
  begin 
  writeln('Файл данных "',fn, '"',' Записи ':40,j*15+1,'-',(j+1)*15); 
  writeln('+---+--------------------------------------------------+----------------------+'); 
  writeln('! № !             Фамилия Имя Отчество                 !         Адрес        !'); 
  writeln('+---+--------------------------------------------------+----------------------+'); 
  writeln(f2,'Файл данных "',fn, '"',' Записи ':40,j*15+1,'-',(j+1)*15); 
  writeln(f2,'+---+--------------------------------------------------+----------------------+'); 
  writeln(f2,'! № !             Фамилия Имя Отчество                 !         Адрес        !'); 
  writeln(f2,'+---+--------------------------------------------------+----------------------+'); 
  i:=1; 
  while not eof(f) and (i<=15) do 
      begin 

  with zhitel do 
  begin 
    with name do 
    begin 
      readln(f,sname);readln(f,fname);readln(f,mname); 
    end; 
    
    readln(f,ad); 
    readln(f,mr); 
    
    readln(f,privivka); 
      
    with date_v do 
    begin 
      readln(f,day);readln(f,month);readln(f,year); 
      if (year>=y) or 
         (year=y-1) and ((month>m) or (month=m) and (day>d)) then 
      begin 
        fio:=name.sname +' '+name.fname+' '+name.mname; 
        writeln('є',(j*15+i):2,' є ', fio:48,' є ',ad:20,' є'); 
        writeln(f2,'є',(j*15+i):2,' є ', fio:48,' є ',ad:20,' є'); 
        inc(i); 
     end; 
    end; 
  end; 
      
     end; 
  writeln('+---+--------------------------------------------------+----------------------+'); 
  writeln(f2,'+---+--------------------------------------------------+----------------------+'); 
  if not eof(f) then 
   begin textcolor(red+blink); write('Нажмите ENTER...'); readln;end 
  else inc(j); 

  end; 

  writeln(f2,'Найдено ',(15*(j-1)+i-1),' человек с просроченной флюрографией'); 
  close(f); close(f2); 
end; 

type 
    menuitems=array [1..6] of string; 
const 
    mainmenu:menuitems = 
       ('   Условие ', 
        '   Файл    ', 
        '   Решить  ', 
        '   Выход   ', 
        '',''); 

     filemenu:menuitems = 
       ('   Новый         ', 
        '   Открыть       ', 
        '   Сохранить как ', 
        '   Просмотреть   ', 
        '   Изменить      ', 
        '   Назад         '); 

    zapmenu:menuitems = 
       ('   Добавить      ', 
        '   Удалить       ', 
        '   Назад         ', 
        '','',''); 

    resmenu:menuitems = 
       ('   Без прививки  ', 
        '   Флюрография   ', 
        '   Назад         ', 
        '','',''); 

Procedure menu(var m:menuitems; kol: byte; var num: byte); 
var i,y: byte; ch: char; 
Begin 

   window(25,8,65,20); 
   textbackground(0); 
   clrscr; 
   textcolor(12); 
       writeln('           +------+            '); 
       writeln('+----------! МЕНЮ !-----------+'); 
       writeln('!          +------+           !'); 
   for i:=1 to kol do 
       writeln('!                             !'); 

   window(25,10+kol+1,65,10+kol+1); 
         write('+-----------------------------+'); 

   window(26,10+2,54,10+kol); 
   textcolor(3); 
   for i:=2 to kol-1 do 
     writeln(m[i]); 
   textcolor(4);write(m[kol]); 

   window(26,10+1,54,10+1); 
   textcolor(15); 
   textbackground(9); 
   clrscr; 
   write(m[1]); 
   i:=1; 
   y:=11; 

   repeat 
      ch:=readkey; 
      case ch of 
       #80: begin 
              window(26,y,54,y);textcolor(3);textbackground(0);clrscr; 
              write(m[i]); 
              if i=kol then 
                 begin 
                   window(26,y,54,y);clrscr;textbackground(0);textcolor(4);write(m[kol]); 
                   i:=1;y:=11; 
                 end 
              else begin inc(i);inc(y);end; 
              window(26,y,54,y);textcolor(15);textbackground(9);clrscr;write(m[i]); 
             end; 
       #72: begin 
              window(26,y,54,y);textcolor(3);textbackground(0);clrscr;write(m[i]); 
              if i=1 then 
                 begin 
                   i:=kol;y:=10+kol; 
                 end 
              else begin i:=i-1;y:=y-1; 
                         if i=kol-1 then begin 
                           window(26,10+kol,54,10+kol);textcolor(4);clrscr;write(m[kol]); end; 
                   end; 
              window(26,y,54,y);textcolor(15);textbackground(9);clrscr;write(m[i]); 
             end; 
     end; 
  until (ch=#13); 
  num:=i; 
end; 


var r, rf, rz, rr: byte; 

begin 
   fn:='ATmp'; 
   assign(f,fn); 

   textbackground(0); 
   clrscr; 
   repeat 
     window(1,1,80,25); textbackground(0); clrscr; 
     menu(mainmenu,4,r); 
     window(1,1,80,25); textbackground(0); clrscr; 
      Case r of 
        1:begin 
            writeln(mainmenu[r]); writeln; 
writeln('  Пусть дан tekstovyi файл, содержащий сведения о жителях, обслужеваемых данной'); 
writeln('поликлиникой.  Сведения содержат следующую информацию:  фамилия, имя,  отчество'); 
writeln('жителя,  адрес, место работы, наличия  прививки  от дифтирии,  дату прохождения'); 
writeln('последней флюрографии.'); 
writeln('  Вывести на экран и в tekstovyi файл:'); 
writeln('  Фамилии и адреса  тех жильцов,  которые  не  сделали  прививку  от   дифтири;'); 
writeln('с данными о жильцах, у которых  на данный момент  просроченна  дата флюрографии'); 
writeln('(дата считается просрочена, если с момента прошло больше года). '); 

            writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 

        2:begin 
          repeat 
            window(1,1,80,25); textbackground(0); clrscr; 
            menu(filemenu,6,rf); 
            window(1,1,80,25); textbackground(0);  clrscr; 
            writeln(mainmenu[r],'->',filemenu[rf]); writeln; 

            Case rf of 
              1:begin newfile;                
                writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
              2:begin fileopen; 
                writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
              3:begin filesave; 
                writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
              4:begin smotret; 
                writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
              5:begin 
                 repeat 
                   window(1,1,80,25); textbackground(0); clrscr; 
                   menu(zapmenu,3,rz); 
                   window(1,1,80,25); textbackground(0);  clrscr; 
                   writeln(mainmenu[r],'->',zapmenu[rz]); writeln; 

                   Case rz of 
                     1:begin add; 
                       writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
                     2:begin del; 
                       writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
                     3:; 
                   end; 
                 until rz=3;  end; 
              6:; 
            end; 
          until rf=6;  end; 

        3:begin 
                 repeat 
                   window(1,1,80,25); textbackground(0); clrscr; 
                   menu(resmenu,3,rr); 
                   window(1,1,80,25); textbackground(0);  clrscr; 
                   writeln(mainmenu[r],'->',resmenu[rr]); writeln; 

                   Case rr of 
                     1:begin reshit1; 
                       textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
                     2:begin reshit2; 
                       textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
                     3:; 
                   end; 
                 until rr=3; 
          end; 

        4:; 
      end; 
   until r=4; 
end.

Если кто-то напишет новую программу буду очень благодарно!
Ответить с цитированием
  (#2 (permalink)) Старый
Кися Кися вне форума
Новичок
 
Сообщений: 7
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 20.05.2006
По умолчанию Вывод на экран данные из картотеки общего пользования - 30.05.2006, 21:37

Всем привет,мне очень нужна ваша помошь! Вот у4словие задачи.

Пусть дан файл,содержащий сведения о жителях обслужеваемых данной поликлиникой.Сведения содержат следующую информацию:фамилия,имя ,отчество жителя,адрес,место работы,наличия прививки от дифтерии,дату прохождения последней флюрографии.
Вывести на экран и в файл:
Фамилии и адреса тех жильцов,которые не сделали прививку от дифтири;с данными о жильцах у которых на данный момент просроченна дата флюрографии(дата считается просрочена,если с момента прошло больше года).



А вот это ее решение,я немогу в ней разобраться,что мне делать при запуске,выдает меню,но я немогуи найти файлы где храняться данные о пациентах и таким образом немогу вывести на экран что от меня требуют.

Код:
program Agunda; 
uses 
  crt, Dos; 

const 
  days : array [0..6] of String[11] = 
    ('Воскресенье','Понедельник','Вторник', 
     'Среда','Четверг','Пятница', 'Суббота'); 

type 
  tfio = record 
    sname, fname, mname: String[20]; 
  end; 

  tdate = record 
    year : WORD; 
    month : 1..12; 
    day : 1..31; 
  end; 


  tzhitel = record 
    name: tfio; 
    ad, mr: string[20]; 
    privivka: 0..1; 
    date_v : tdate; 
  end; 

var 
  zhitel : tzhitel; 
  f: text; 
  fn: string[40]; 

procedure newfile; 
begin 
  {$I-} 
    rewrite(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Не возможно создать!!! Защита от записи?'); 
    exit; 
  end; 

  writeln('Файл создан'); fn:='ATmp'; 
  close(f); 
end; 

procedure fileopen; 
var f2:text; f2n:string; 
begin 
  write('Имя файла: '); readln(f2n); assign(f2,f2n); 
  {$I-} 
    reset(f2); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Не найден такой файл!'); 
    exit; 
  end; 
  close(f2); 

  assign(f,f2n); 
  writeln('Файл загружен'); fn:=f2n; 
end; 

procedure filesave; 
var f2: text; f2n:string; 
begin 
  {$I-} 
    reset(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Надо сначала создать или открыть файл!'); 
    exit; 
  end; 

  write('Имя файла: '); readln(f2n); assign(f2,f2n); 
  {$I-} 
    rewrite(f2); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Не возможно сохранить!!! Защита от записи?'); 
    exit; 
  end; 
  
  close(f2); erase(f2); 
  close(f); 
  rename(f,f2n); 

  writeln('Файл сохранен');  fn:=f2n; 
end; 

procedure smotret; 
var i,j: byte; fio: string[16]; 
begin 
  {$I-} 
    reset(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Надо сначала создать или открыть файл!'); 
    exit; 
  end; 

  if eof(f) then writeln('Файл пуст'); 
  j:=0; 
  while not eof(f) do 
  begin 
  writeln('Файл данных "',fn, '"',' Записи ':40,j*15+1,'-',(j+1)*15); 
  writeln('+---+------------------+------------------+------------------+---+------------+'); 
  writeln('! № !      ФИО         !     Адрес        !   Место работы   ! П !  Дата флюр !'); 
  writeln('+---+------------------+------------------+------------------+---+------------+'); 
  i:=1; 
  while not eof(f) and (i<=15) do 
      begin 

  with zhitel do 
  begin 
    with name do 
    begin 
      readln(f,sname);readln(f,fname);readln(f,mname); 
      fio:=sname +' '+fname[1]+'.'+mname[1]+'.'; 
      write('є',(j*15+i):2,' є ',fio:16,' є '); 
    end; 
    
    readln(f,ad);fio:=ad; write(fio:16,' є '); 
    readln(f,mr);fio:=mr; write(fio:16,' є '); 
    
    readln(f,privivka); 
    if privivka=1 then write('+',' є ') else write('-',' є '); 
      
    with date_v do 
    begin 
      readln(f,day);readln(f,month);readln(f,year); 
      writeln(day:2,'/', month:2,'/', year:4,' є'); 
    end; 
  end; 
      inc(i); 
     end; 
 writeln('+---+------------------+------------------+------------------+---+------------+'); 
  if not eof(f) then 
   begin writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln;end 
  else inc(j); 

  end; 
  close(f); 
end; 

procedure add; 
var ch: char; 
begin 
  {$I-} 
    append(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Надо сначала создать или открыть файл!'); 
    exit; 
  end; 

 repeat 
  reset(f); 
  if not eof(f) then 
   begin append(f); writeln(f); end 
  else append(f); 
  with zhitel do 
  begin 
    writeln('Информация о жителе':55); 
    with name do 
    begin 
      write('Фамилия: ':40);     readln(sname); writeln(f,sname); 
      write('Имя: ':40);     readln(fname); writeln(f,fname); 
      write('Отчество: ':40);     readln(mname); writeln(f,mname); 
    end; 
    
    write('Адрес: ':40);readln(ad);writeln(f,ad); 
    write('Место работы: ':40);readln(mr);writeln(f,mr); 
    
    write('Прививка (0/1): ':40);readln(privivka);writeln(f,privivka); 
      
    writeln('Дата  флюрографии (ДД ММ ГГГГ): ':55); 
    with date_v do 
    begin 
      write('День: ':40);readln(day);writeln(f,day); 
      write('Месяц: ':40);readln(month);writeln(f,month); 
      write('Год: ':40);readln(year); write(f,year); 
    end; 
  end; 

  write('Добавить еще? (Y/N) ');readln(ch); 
 until UpCase(ch)='N'; 

 close(f); 
end; 

procedure del; 
var 
  i,j,n : integer; 
  f2: text; 
  f2n,s: string; 
  ch:char; 
begin 
  {$I-} 
    reset(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Надо сначала создать или открыть файл!'); 
    exit; 
  end; 

  assign(f2, '~tmp'); 
  {$I-} 
    rewrite(f2); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Не возможно записать!!! Защита от записи?'); 
    exit; 
  end; 

 repeat 
  repeat 
   write('Введите номер = '); readln(n); 
  until (n>0); 

  i:=1; 
  while not eof(f) do 
  begin 
    for j:=1 to 8 do 
      begin readln(f, s); if i<>n then writeln(f2, s);end; 
    readln(f, s); if i<>n then write(f2, s); 
    inc(i); 
    if not eof(f) and ((i<>n) and (n>1) or 
       (i<>2)and(n=1)) then writeln(f2); 
  end; 
  close(f); erase(f); 
  close(f2); rename(f2, fn); 
  assign(f, fn); 
  reset(f); 
  assign(f2, '~tmp'); 
  rewrite(f2); 

  writeln('Удалить еще? (Y/N) ');readln(ch); 
 until UpCase(ch)='N'; 

 close(f);close(f2); 
end; 

procedure reshit1; 
var 
  y, m, d, dow : Word; 
  i,j: word; 
  f2: text; f2n: string; fio:string[48]; 
begin 
  GetDate(y,m,d,dow); 
  WriteLn('Сегодня ', days[dow],', ', 
          m:2, '/', d:2, '/', y:4); 

  {$I-} 
    reset(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Надо сначала создать или открыть файл!'); 
    exit; 
  end; 

  write('Имя файла результатов: '); readln(f2n); assign(f2,f2n); 
  {$I-} 
    rewrite(f2); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Не возможно сохранить!!! Защита от записи?'); 
    exit; 
  end; 

  if eof(f) then writeln('Файл пуст'); 
  j:=0;   i:=1; 
  while not eof(f) do 
  begin 
  writeln('Файл данных "',fn, '"',' Записи ':40,j*15+1,'-',(j+1)*15); 
  writeln(f2,'Файл данных "',fn, '"',' Записи ':40,j*15+1,'-',(j+1)*15); 
  writeln('+---+--------------------------------------------------+----------------------+'); 
  writeln('! № !             Фамилия Имя Отчество                 !         Адрес        !'); 
  writeln('+---+--------------------------------------------------+----------------------+'); 
  writeln(f2,'+---+--------------------------------------------------+----------------------+'); 
  writeln(f2,'! № !             Фамилия Имя Отчество                 !         Адрес        !'); 
  writeln(f2,'+---+--------------------------------------------------+----------------------+'); 
  i:=1; 
  while not eof(f) and (i<=15) do 
      begin 

  with zhitel do 
  begin 
    with name do 
    begin 
      readln(f,sname);readln(f,fname);readln(f,mname); 
    end; 
    
    readln(f,ad); 
    readln(f,mr); 
    
    readln(f,privivka); 
      
    with date_v do 
    begin 
      readln(f,day);readln(f,month);readln(f,year); 
    end; 

    if privivka<>1 then 
    begin 
      fio:=name.sname +' '+name.fname+' '+name.mname; 
      writeln('є',(j*15+i):2,' є ', fio:48,' є ',ad:20,' є'); 
      writeln(f2,'є',(j*15+i):2,' є ', fio:48,' є ',ad:20,' є'); 
          inc(i); 
    end; 
  end; 
      
     end; 
  writeln('+---+--------------------------------------------------+----------------------+'); 
  writeln(f2,'+---+--------------------------------------------------+----------------------+'); 
  if not eof(f) then 
   begin textcolor(red+blink); write('Нажмите ENTER...'); readln;end 
  else inc(j); 

  end; 
  writeln(f2,'Найдено ',(15*(j-1)+i-1),' человек, не сделавших прививку'); 
  close(f); close(f2); 
end; 

procedure reshit2; 
var 
  y, m, d, dow : Word; 
  i,j: word; 
  f2: text; f2n: string; fio:string[48]; 
begin 
  GetDate(y,m,d,dow); 
  WriteLn('Сегодня ', days[dow],', ', 
          m:2, '/', d:2, '/', y:4); 

  {$I-} 
    reset(f); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Надо сначала создать или открыть файл!'); 
    exit; 
  end; 

  write('Имя файла результатов: '); readln(f2n); assign(f2,f2n); 
  {$I-} 
    rewrite(f2); 
  {$I+} 
  If IOResult<>0 then 
  begin 
    writeln('Не возможно сохранить!!! Защита от записи?'); 
    exit; 
  end; 

  if eof(f) then writeln('Файл пуст'); 
  j:=0;      i:=1; 
  while not eof(f) do 
  begin 
  writeln('Файл данных "',fn, '"',' Записи ':40,j*15+1,'-',(j+1)*15); 
  writeln('+---+--------------------------------------------------+----------------------+'); 
  writeln('! № !             Фамилия Имя Отчество                 !         Адрес        !'); 
  writeln('+---+--------------------------------------------------+----------------------+'); 
  writeln(f2,'Файл данных "',fn, '"',' Записи ':40,j*15+1,'-',(j+1)*15); 
  writeln(f2,'+---+--------------------------------------------------+----------------------+'); 
  writeln(f2,'! № !             Фамилия Имя Отчество                 !         Адрес        !'); 
  writeln(f2,'+---+--------------------------------------------------+----------------------+'); 
  i:=1; 
  while not eof(f) and (i<=15) do 
      begin 

  with zhitel do 
  begin 
    with name do 
    begin 
      readln(f,sname);readln(f,fname);readln(f,mname); 
    end; 
    
    readln(f,ad); 
    readln(f,mr); 
    
    readln(f,privivka); 
      
    with date_v do 
    begin 
      readln(f,day);readln(f,month);readln(f,year); 
      if (year>=y) or 
         (year=y-1) and ((month>m) or (month=m) and (day>d)) then 
      begin 
        fio:=name.sname +' '+name.fname+' '+name.mname; 
        writeln('є',(j*15+i):2,' є ', fio:48,' є ',ad:20,' є'); 
        writeln(f2,'є',(j*15+i):2,' є ', fio:48,' є ',ad:20,' є'); 
        inc(i); 
     end; 
    end; 
  end; 
      
     end; 
  writeln('+---+--------------------------------------------------+----------------------+'); 
  writeln(f2,'+---+--------------------------------------------------+----------------------+'); 
  if not eof(f) then 
   begin textcolor(red+blink); write('Нажмите ENTER...'); readln;end 
  else inc(j); 

  end; 

  writeln(f2,'Найдено ',(15*(j-1)+i-1),' человек с просроченной флюрографией'); 
  close(f); close(f2); 
end; 

type 
    menuitems=array [1..6] of string; 
const 
    mainmenu:menuitems = 
       ('   Условие ', 
        '   Файл    ', 
        '   Решить  ', 
        '   Выход   ', 
        '',''); 

     filemenu:menuitems = 
       ('   Новый         ', 
        '   Открыть       ', 
        '   Сохранить как ', 
        '   Просмотреть   ', 
        '   Изменить      ', 
        '   Назад         '); 

    zapmenu:menuitems = 
       ('   Добавить      ', 
        '   Удалить       ', 
        '   Назад         ', 
        '','',''); 

    resmenu:menuitems = 
       ('   Без прививки  ', 
        '   Флюрография   ', 
        '   Назад         ', 
        '','',''); 

Procedure menu(var m:menuitems; kol: byte; var num: byte); 
var i,y: byte; ch: char; 
Begin 

   window(25,8,65,20); 
   textbackground(0); 
   clrscr; 
   textcolor(12); 
       writeln('           +------+            '); 
       writeln('+----------! МЕНЮ !-----------+'); 
       writeln('!          +------+           !'); 
   for i:=1 to kol do 
       writeln('!                             !'); 

   window(25,10+kol+1,65,10+kol+1); 
         write('+-----------------------------+'); 

   window(26,10+2,54,10+kol); 
   textcolor(3); 
   for i:=2 to kol-1 do 
     writeln(m[i]); 
   textcolor(4);write(m[kol]); 

   window(26,10+1,54,10+1); 
   textcolor(15); 
   textbackground(9); 
   clrscr; 
   write(m[1]); 
   i:=1; 
   y:=11; 

   repeat 
      ch:=readkey; 
      case ch of 
       #80: begin 
              window(26,y,54,y);textcolor(3);textbackground(0);clrscr; 
              write(m[i]); 
              if i=kol then 
                 begin 
                   window(26,y,54,y);clrscr;textbackground(0);textcolor(4);write(m[kol]); 
                   i:=1;y:=11; 
                 end 
              else begin inc(i);inc(y);end; 
              window(26,y,54,y);textcolor(15);textbackground(9);clrscr;write(m[i]); 
             end; 
       #72: begin 
              window(26,y,54,y);textcolor(3);textbackground(0);clrscr;write(m[i]); 
              if i=1 then 
                 begin 
                   i:=kol;y:=10+kol; 
                 end 
              else begin i:=i-1;y:=y-1; 
                         if i=kol-1 then begin 
                           window(26,10+kol,54,10+kol);textcolor(4);clrscr;write(m[kol]); end; 
                   end; 
              window(26,y,54,y);textcolor(15);textbackground(9);clrscr;write(m[i]); 
             end; 
     end; 
  until (ch=#13); 
  num:=i; 
end; 


var r, rf, rz, rr: byte; 

begin 
   fn:='ATmp'; 
   assign(f,fn); 

   textbackground(0); 
   clrscr; 
   repeat 
     window(1,1,80,25); textbackground(0); clrscr; 
     menu(mainmenu,4,r); 
     window(1,1,80,25); textbackground(0); clrscr; 
      Case r of 
        1:begin 
            writeln(mainmenu[r]); writeln; 
writeln('  Пусть дан tekstovyi файл, содержащий сведения о жителях, обслужеваемых данной'); 
writeln('поликлиникой.  Сведения содержат следующую информацию:  фамилия, имя,  отчество'); 
writeln('жителя,  адрес, место работы, наличия  прививки  от дифтирии,  дату прохождения'); 
writeln('последней флюрографии.'); 
writeln('  Вывести на экран и в tekstovyi файл:'); 
writeln('  Фамилии и адреса  тех жильцов,  которые  не  сделали  прививку  от   дифтири;'); 
writeln('с данными о жильцах, у которых  на данный момент  просроченна  дата флюрографии'); 
writeln('(дата считается просрочена, если с момента прошло больше года). '); 

            writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 

        2:begin 
          repeat 
            window(1,1,80,25); textbackground(0); clrscr; 
            menu(filemenu,6,rf); 
            window(1,1,80,25); textbackground(0);  clrscr; 
            writeln(mainmenu[r],'->',filemenu[rf]); writeln; 

            Case rf of 
              1:begin newfile;                
                writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
              2:begin fileopen; 
                writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
              3:begin filesave; 
                writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
              4:begin smotret; 
                writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
              5:begin 
                 repeat 
                   window(1,1,80,25); textbackground(0); clrscr; 
                   menu(zapmenu,3,rz); 
                   window(1,1,80,25); textbackground(0);  clrscr; 
                   writeln(mainmenu[r],'->',zapmenu[rz]); writeln; 

                   Case rz of 
                     1:begin add; 
                       writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
                     2:begin del; 
                       writeln; textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
                     3:; 
                   end; 
                 until rz=3;  end; 
              6:; 
            end; 
          until rf=6;  end; 

        3:begin 
                 repeat 
                   window(1,1,80,25); textbackground(0); clrscr; 
                   menu(resmenu,3,rr); 
                   window(1,1,80,25); textbackground(0);  clrscr; 
                   writeln(mainmenu[r],'->',resmenu[rr]); writeln; 

                   Case rr of 
                     1:begin reshit1; 
                       textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
                     2:begin reshit2; 
                       textcolor(red+blink); write('Нажмите ENTER...'); readln  end; 
                     3:; 
                   end; 
                 until rr=3; 
          end; 

        4:; 
      end; 
   until r=4; 
end.

Если кто-то напишет новую программу буду очень благодарно!
Ответить с цитированием
  (#3 (permalink)) Старый
Dimon_x_87 Dimon_x_87 вне форума
Новичок
 
Сообщений: 2
Сказал(а) спасибо: 0
Поблагодарили 0 раз(а) в 0 сообщениях
Регистрация: 24.08.2006
Post 24.08.2006, 16:26

Программа отлично работает, но save файл только один.
Можно дополнительно создать процедуру для обновления файла, содержащего имя файла результатов.
Потом можно будет выводить имя файла в окне открытия файла результатов, и "РЕШИТЬ".
Оформление так себе, что за ! ! ! ! ! в окне меню?
Ответить с цитированием
Ads
Ответ

Опции темы
Опции просмотра

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.
Trackbacks are Вкл.
Pingbacks are Вкл.
Refbacks are Выкл.


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Вывод на экран прямоугольника olchery Assembler 0 05.03.2011 16:51
Вывод на экран toxic Prolog 16 24.11.2009 15:01
CriticalSection вывод на экран сообщений sashar2 Visual C++ 7 04.01.2008 15:16
Вывод сырого растра на экран Pr0phet Программирование графики 2 23.08.2007 01:11
Получение и вывод на экран строки в TASM Zar Вопросы начинающих программистов 6 30.11.2006 22:32
Вывод строки на экран ukrana Assembler 7 04.05.2006 18:33
Обход и вывод дерева на экран AleksT_0 Алгоритмы 4 13.03.2006 10:28
Как сделать вывод на экран информации БейБа Pascal 1 05.03.2006 23:04
Рекурсия вывод на экран чисел keeply Pascal 1 05.12.2005 10:51
Пользовательские сообщения вывод на экран Sterblish Visual C++ 3 11.03.2005 09:07
Вывод адреса на экран Nikolal Assembler 1 02.03.2004 21:19
Вывод управляющих ASCII символов на экран chainick C++ Builder 0 09.09.2003 01:57



Powered by vBulletin® Version 3.8.7
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
Нardforum.ru - компьютерный форум и программирование, форум программистов