паскаль. Записи. Файлы.

[Антон Лысенко]

Запрограммировать записную книжку.Поля:Имя,Фамилия, номер телефона. Организовать запись данных, удаление данных, поиск по фамилии, поиск номеру телефону.

Не могу организовать удаление. Сделал так что должно удалять с найденного элемента и до конца файла, но даже это не работает.
Помогите идеями как сделать так что бы удалить только один элемент.

Вот то что я сделал:

program Lab1;

{$APPTYPE CONSOLE}

uses
  SysUtils;

type  Book=record
       Name:string[15];
       Surname:string[15];
       Phone:string[15];
     end;
var fBook:file of book;
    B:book;
    C:char;
    flag:boolean;
    N:byte;
procedure AddContact;
 begin
   writeln('Add contact');
   flag:=true;
   repeat
    reset(fBook);
    Seek(fBook,FileSize(fBook));
    writeln('Input Name'); readln(B.Name);
    writeln('Input Surname'); readln(B.Surname);
    writeln('Input Telephone'); readln(B.Phone);
    write(fBook,B);
    writeln('Continue?(Y/N)'); readln(C);
     if(C='N')xor(C='n')then
       flag:=false;
      until not(flag);
       close(fBook);
  { TODO -oUser -cConsole Main : Insert code here }
end;
 procedure SearchBySurname;
   var SSName:string[15]; tick:boolean;
    begin
      writeln('Enter Surname to find contact'); readln(SSName);
      reset(fBook);
      while not(EoF(fBook))do
       begin
        read(fBook,B);
        if (b.Surname=SSName) then
         with B do
          begin
           writeln(Name,' ',Surname,' ',Phone);
           tick:=true;
          end
       end;
       if not tick then
        writeln('contact was not found');
       closefile(fBook);
    end;
 procedure SearchByPhone;
   var SPhone:string[15]; tick:boolean;
    begin
      writeln('Enter telephone to find contact'); readln(SPhone);
      reset(fBook);
      while not(EoF(fBook))do
       begin
        read(fBook,B);
        if (b.Phone=SPhone) then
         with B do
          begin
           writeln(Name,' ',Surname,' ',Phone);
           tick:=true;
          end
       end;
       if not tick then
        writeln('contact was not found');
       closefile(fBook);
    end;

 Procedure Delete;
  var fpose:integer;
      V:char;
      SSName:string[15];
  begin
    writeln('Enter Surname to find contact'); readln(SSname);
      reset(fBook);
      fpose:=0;
      while not(EoF(fBook))do
       begin
        read(fBook,B);
        if (b.Surname=SSname) then
         with B do
          begin
           writeln(Name,' ',Surname,' ',Phone);
           fpose:=FilePos(fBook)
          end
           else fpose:=FileSize(fBook)+1;
          end;
    writeln('Delete this contact? (Y/N)'); readln(V);
    if (V='y')xor(V='Y')then
     begin
      seek(fBook,fpose-1);
      truncate(fbook);
      writeln('contact is removed');
     end
      else
      writeln('Remove failed');
  end;

begin
 assign(fBook,'fBook1.dat');
 writeln('  Menu');
 writeln('1 - Add contact');
 writeln('2 - Search contact by Surname');
 writeln('3 - Search contact by telephone');
 writeln('4 - Delete contact');
 writeln('5 - Close');
  repeat
write('select an action - ');  readln(N);
 case N of
  1:AddContact;
  2:SearchBySurname;
  3:SearchByPhone;
  4:Delete;
  5:;
  else
  end;
  readln;
  until N=5
end.

[VadikV]

разбираться лень, но то, что сходу увиделось - не закрываешь файл closefile(fBook) в процедуре удаления - изменения не сохраняются не диске.

[Антон Лысенко]

Ну и на этом спасибо. Еще один момент! Если удалять последний элемент то он удаляется, а при удалении какого-то другого, не удаляется ничего.

[Step_UA]

У вас после нахождения удаляемого элемента, усекается файл на одну запись с конца. Необходимо "подтянуть" все последующие записи на одну позицию к началу или на место удаляемой записи - записать последнюю из файла, после чего усечь его длину

 Procedure Delete;
  var fpose:integer;
      V:char;
      SSName:string[15];
  begin
    writeln('Enter Surname to find contact'); readln(SSname);
      reset(fBook);
      while not(EoF(fBook))do
       begin
        read(fBook,B);
        if (b.Surname=SSname) then
         with B do
          begin
           writeln(Name,' ',Surname,' ',Phone);
           writeln('Delete this contact? (Y/N)'); readln(V);
           if (V='y')xor(V='Y')then
             begin
              for fpose:=FilePos(fBook) to filesize(fBook)-1 do
               begin
                seek(fBook,fpose);
                read(fBook,B);
                seek(fBook,fpose-1);
                write(fBook,B)
               end;
               {//вместо вышестоящего цикла For
              fpose:=Filepos(fBook);
              if fpose<>FileSize(fBook)-1 then
               begin
                seek(fBook,filesize(fBook)-1);
                read(fBook,B);
                seek(fBook,fpose-1);
                write(fBook,B);
               end;
              seek(fBook,filesize(fBook)-1)
              }
              Truncate(fBook)
             end
            else
             writeln('Remove failed');
          end
       end;
  end;

[Serge_Bliznykov]

Step_UA, +1


Антон Лысенко, для общего развития рекомендую ознакомиться с темой:
как удалить значение в типизированных файлах
ну и отдельно ещё можно посмотреть эти два моих поста ТУТ и ТУТ. (правда, они повторяются, там все об одном и том же... )

[phomm]

В теле программы Меню рисуется только 1 раз, потом цикл чтения действий, после того как экран забьется разной инфой, вспомнить какой пункт меню какую команду выполняет - нельзя (на винХР правда можно будет промотать вверх), поставьте REPEAT выше (после Assign ) и будет меню каждый раз записываться (обычно большинство таких программ так и устроено)
Ещё в конце можно убрать "else" "readln;", ну и "5 :;" заодно - они лишние

[Антон Лысенко]

Учёл все замечания и сел за работу. Большое спасибо за помощь!)