Оглавление Работа с записями - файл записей.


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

---- Исходный текст программы ----
Program menu1;
Uses crt, WinDOS;
  {Модуль WinDOS можно найти в комплекте BP (Borland Pascal)
   Если кому-то нужны модули или весь BP или модули 
   TP (Tubro Professional), пишите - выложу на сайт.
   Можно обойтись без WinDOS, если выкинуть из программы Procedure FileList; - 
   которая выдает список файлов *.dat в рабочей папке}
Const KP=8;

Type arr = array [1..KP] of String;

     anketa=record
     FIO: string[45];
     dat_r: string[8];
     adres: string[50];
     curs: 1..5;
     gruppa: string[3]
      end;

Var i,YY: byte;
    C,C1: Char;
    a: arr;
    ank1: anketa;
    Kolic: Integer;
    FA: file of anketa;
    FName:string;

Procedure ReadFileName(var FN:string);
begin
  write(' Введите имя файла -> ');
  readln(FN);
end;

Procedure WriteToFile(FN:string; App: Boolean);
{Citaet s klav, zapis v file}
var ta: byte; IOR: Integer; FSize: Longint;
begin ta:= textattr;
  Kolic:= 0;
  Assign(FA,FN);
  If App then
    begin
     {$I-}
     reset(FA);
     {$I+}
      IOR:= IOResult;
      If IOR<>0 then
        begin writeln(' Ошибка чтения- файл не найден, IOR= ',IOR);
           writeln(' Жми Enter !!'); readln; clrscr;
            exit;
        end;
      FSize:= filesize(FA); Kolic:= FSize;
      seek(FA,FSize);
      writeln(' **** Сейчас ',FSize,' анкет в файле. Добавь еще... ***');
    end else
    rewrite(FA);
  clrscr;
  writeln(' Введите анкеты. Выход - пустая фамилия');
  Repeat
  writeln(' ********* ',kolic+1,'-я анкета  ****************');
   write(' Фамилия, И.О.      -> '); readln (ank1.FIO);
   if ank1.FIO = '' then break;
   inc(Kolic);
   write(' Дата рожд          -> '); readln (ank1.dat_r);
   write(' Адрес              -> '); readln (ank1.adres);
   write(' Курс (1..5)        -> '); readln (ank1.curs);
   write(' Группа (до 3 симв) -> '); readln (ank1.gruppa);
   writeln(' *******************************************');
   writeln;
   write(FA,ank1);
  until false;
  Close(FA);
  clrscr;
  textattr:= ta;
end;

procedure ReadFromFile(FN:string);
var IOR,Nomer: Integer; ta: byte;
 ss: Char;
begin
 ta:= textattr;
 Assign(FA,FN);
 {$I-}
  Reset(FA);
 {$I+}
  IOR:= IOREsult;
  If IOR<> 0 then
    begin writeln(' Ошибка чтения: файл не найден, IOR= ',IOR);
     writeln(' Жми Enter !!'); readln; clrscr;
     exit;
    end;
 writeln(' ***** Прочтено из файла '+FN+' ******');
 writeln;  Nomer:= 1;
  while not eof(FA) do
   begin
      read(FA,ank1);
      writeln(' ***** Анкета N: ',Nomer,' *********');
      with ank1 do
      begin
      writeln(' Фамилия:     '+FIO);
      writeln(' Дата рожден: ', dat_r);
      writeln(' Адрес:       ',adres);
      writeln(' Группа:      ',gruppa);
      writeln(' Курс: ',curs);
      end;
      if Nomer mod 4 = 0 then
        begin
          write(' Для продолжения нажмите клавишу F '); ss:= readkey;
          if ss in ['f','F'] then
            begin
              clrscr;
            end;
        end;
      inc(Nomer);
   end;
   Close(FA);
   write(' Для продолжения жмите Enter'); readln; clrscr;
end;

procedure FindEdit(FN:string);
label me1,me2;
var IOR,Nomer,FSize,ii,kk: Integer; ta,xx: byte;
 ss: Char; busik: string;
begin
 Assign(FA,FN);
 {$I-}
  Reset(FA);
 {$I+}
  IOR:= IOREsult;
  If IOR<> 0 then
    begin writeln(' Ошибка чтения: файл не найден, IOR= ',IOR);
     writeln(' Жми Enter !!'); readln; clrscr;
     exit;
    end;
 FSize:= FileSize(FA);
 clrscr;
 writeln(' ****** Размер файла= ',FSize,'  Жми Enter ***********');
 Repeat
 write(' Введи номер записи для поиска (1..',FSize,') -> '); readln(Nomer);
 seek(FA,Nomer-1);
 until (Nomer > 0) and (nomer <= FSize);

 read(FA,ank1);
 me1: textattr:= $1e; clrscr;
      writeln(' ***** Анкета N: ',Nomer,' *********');
      with ank1 do
      begin
      writeln(' Фамилия     : '+FIO);
      writeln(' Дата рожден : ', dat_r);
      writeln(' Адрес       : ',adres);
      writeln(' Группа      : ',gruppa);
      writeln(' Курс        : ',curs);
      end;

      writeln; writeln(' Для редактирования жми клавишу:');
      writeln         (' ----------------------');
      writeln(' F - Фамилия');
      writeln(' D - Дата рожд');
      writeln(' A - Адрес');
      writeln(' G - Группа');
      writeln(' K - Курс');
      writeln(' E - ВЫХОД');
      ss:= readkey;
      ta := textattr; textattr:= $72;
    me2: case ss of
      'F','f': begin
                write(' Введи FIO         -> ');
                textattr:= $0a; xx:= whereX; write('            ');
                gotoxy(xx,whereY);
                readln(ank1.FIO);
               end;
      'D','d': begin
                write(' Введи дату рожден -> ');
                textattr:= $0a; xx:= whereX; write('            ');
                gotoxy(xx,whereY);
                 readln(ank1.dat_r);
               end;
      'A','a': begin
                write(' Введи адрес       -> ');
                textattr:= $0a; xx:= whereX; write('                 ');
                gotoxy(xx,whereY);
                readln(ank1.adres);
               end;
      'G','g': begin
                write(' Введи группу      -> ');
                textattr:= $0a; xx:= whereX; write('   ');
                gotoxy(xx,whereY);
                readln(ank1.gruppa);
               end;
      'K','k': begin
                 write(' Введи курс (1..5) -> ');
                 textattr:= $0a; xx:= whereX; write(' ');
                 gotoxy(xx,whereY);
                 readln(busik);
                 val(busik,kk,ii); if ii<>0 then
                   begin textattr:= $7C;
                     writeln(' Error!');
                     goto me2;
                   end;
                   if (kk>0) and (kk<6) then
                   ank1.curs:=kk else
                     begin writeln(' ',kk,' - неверное значение');
                       goto me2;
                     end;
               end;
         'E','e','у','У': begin textattr:= $1e; clrscr;
                          end;
      end;

  if not (ss in ['E','e']) then
     begin
       clrscr;
       goto me1;
     end;

  seek(FA,Nomer-1);
  write(FA,ank1);
   textattr:= ta;
   Close(FA);
end;

type ts3 = string[3];

Procedure FileList;
var DirInfo : TSearchRec; {Нужно подключить модуль WinDOS в предложении uses}
Begin
 FindFirst('*.DAT', faArchive, DirInfo); {Находим 1-й файл с расширением DAT}
 { Аналог команды DIR *.DAT }
 While DosError = 0 Do {если больше нет таких файлов, то DosError <> 0 }
  Begin
   WriteLn(' ',DirInfo.Name); {выводим на экран имя найденного файла}
   FindNext(DirInfo); {Находим следующий файл с расширением DAT}
  End;
end;

begin { ********** Начало главной программы *************** }
 textattr := $1F;
 clrscr;
 a[1]:=' Ввести с клав,записать в файл ';
 a[2]:=' Прочесть из файла на экран    ';
 a[3]:=' Добавить анкеты к файлу       ';
 a[4]:=' Редактировать заданную запись ';
 a[5]:=' Выход (Esc)                   ';
 a[6]:=' Создать файл                  ';
 a[7]:=' Удалить файл                  ';
 a[8]:=' Показать список файлов .dat   ';

 yy:= 1;

 Repeat
 gotoxy(1,1);
 For i:=1 to KP do
  begin
    if i=yy then
      textattr:= $F0 else
      textattr:= $17;
   Writeln (a[i]);
  end;
  gotoxy(1,yy);
  textattr:= $1F;

  C := Readkey;
Case C of
#0: begin
C1:= readkey;
case c1 of
#72{Up}: begin
if yy > 1 then dec(yy) else
yy:= KP;
end;
#80{Down}: begin
if yy < KP then inc(yy) else
yy:= 1;
end;
end {case C1}
end;
  #13{Enter}: begin
         textcolor(14);yy:= wherey;
         clrscr;
         Case yy Of
          1: begin
               ReadFileName(FName);
               WriteToFile(FName,false);
             end;
          2: begin
              ReadFileName(FName);
              ReadFromFile(FName);
             end;
          3: begin
              ReadFileName(FName);
              WriteToFile(FName,true);
             end;
          4: begin
              ReadFileName(FName);
              FindEdit(FName);
             end;
          5: begin
               exit;
             end;
          6: begin
              ReadFileName(FName);
              Assign(FA,Fname);
              rewrite(FA);
              Close(FA);
             end;
          7: begin
              ReadFileName(FName);
              Assign(FA,Fname);
              erase(FA);
             end;
          8: begin FileList; writeln;
               write(' Для продолжения жмите Enter'); readln;
             end;
         end;
      end;
  end;
 until c = #27;
end.
Rambler's Top100
Hosted by uCoz