Форум «Всё о Паскале» _ Задачи _ Удаление строки из текстового файла в БД
Автор: hemm 16.12.2011 22:53
База данных. Не могу наладить удаление конкретной записи. Удаляются данные из массива, но остаются символы, разделяющие колонки. Получается такая картина: *Создал две записи. Затем удалил запись №1, но пустые колонки все равно остались.
Буду благодарен за любые советы по улучшению и упрощению кода. *процедуру проверки на существования текстового файла пока не делал, поэтому для запуска программы в том же каталоге надо создать файл DB.TXT Проверял на FREEPASCAL.
Procedure ReadAll; Var f: text; Begin n:=0; Assign(f,'db.txt');
{$I-} Reset(f); {$I+} If IOresult<>0 then Writeln('Ошибка: невозможно открыть исходный файл. Повторите ввод.'); While not EOF(f) do Begin inc(n); Readln(f,Massive[n].SecondName); Readln(f,Massive[n].FirstName); Readln(f,Massive[n].FatherName); Readln(f,Massive[n].Group); Readln(f,Massive[n].Course); Readln(f); End; close(f); End;
{Сохранение отредактированной базы данных в файл}
Procedure SaveAll; Var i:integer; f:text; Begin Assign(f,'db.txt'); ReWrite(f); For i:=1 To n do Begin Writeln(f,Massive[i].SecondName); Writeln(f,Massive[i].FirstName); Writeln(f,Massive[i].FatherName); Writeln(f,Massive[i].Group); Writeln(f,Massive[i].Course); Writeln(f); End; close(f); End;
{Линия}
Procedure Line; Var k:integer; Begin For k:=1 To 79 do Begin Write('-'); End; Writeln; End;
{Оглавление}
Procedure MainTitle; Var k,m,n:integer; Begin Line; Write('Фамилия |'); Write(' Имя |'); Write(' Отчество |'); Write(' Группа |');Write(' Курс'); Writeln; Line; End;
{Оглавление редактирования} Procedure MainTitleEdit; Var k,m,n:integer; Begin Line; Write('№ | Фамилия |'); Write(' Имя |'); Write(' Отчество |'); Write('Группа |'); Writeln; Line; End;
{Добавление записи} Procedure Add; Var i:integer; Begin Clrscr; inc(n); Writeln('Добавление новой записи о студенте:'); Writeln; Write('Фамилия........: '); Readln(Massive[n].SecondName); Write('Имя............: '); Readln(Massive[n].FirstName); Write('Отчество.......: '); Readln(Massive[n].FatherName); Write('Номер группы...: '); Readln(Massive[n].Group); Write('Курс...........: '); Readln(Massive[n].Course);
SaveAll;
Writeln;
Write('Запись успешно добавлена в базу данных');
Delay(1000);
Menu;
End;
{Вывод записей базы данных на экран}
Procedure WriteAll; Var i,j:integer; s1,s2,s3,s4:string;
Begin clrscr;
MainTitle;
For i:=1 To n do
{-------- ВОТ ЗДЕСЬ ПОДСКАЖИТЕ КАК УПРОСТИТЬ} Begin
s1:=''; s2:=''; s3:=''; s4:='';
For j:=1 To 18-length(Massive[i].SecondName) do s1:=s1+' '; For j:=1 To 8-length(Massive[i].FirstName) do s2:=s2+' '; For j:=1 To 18-length(Massive[i].FatherName) do s3:=s3+' '; For j:=1 To 18-length(Massive[i].Group) do s4:=s4+' ';
Begin {-------- ВОТ ЗДЕСЬ ПОДСКАЖИТЕ КАК УПРОСТИТЬ}
s1:=''; s2:=''; s3:='';
For j:=1 To 18-length(Massive[i].SecondName) do s1:=s1+' '; For j:=1 To 8-length(Massive[i].FirstName) do s2:=s2+' '; For j:=1 To 18-length(Massive[i].FatherName) do s3:=s3+' ';
If not Swop then Writeln('Записей с такой фамилией не обнаружено либо имя указано неверно');
Writeln;
Line;
Writeln(' |1|...... Повторный поиск'); Writeln(' |0|...... Выход из программы'); Writeln(' |Enter|.. Переход в меню');
Line;
Write('Ваш выбор| ');
Readln(x);
Case x of '1':SearchSecondName; '0':halt;
Else Menu; End; End;
{Поиск по группе}
Procedure SearchGroup; Var SG:string; i,j:integer; s1,s2,s3:string; Swop:boolean; x:char;
Begin
clrscr;
SearchTitle;
Write('Введите номер группы: '); Readln(SG); Writeln;
Swop:=false;
MainTitle;
For i:=1 To n do If Massive[i].Group=SG then Begin
s1:=''; s2:=''; s3:='';
For j:=1 To 18-length(Massive[i].SecondName) do s1:=s1+' '; For j:=1 To 8-length(Massive[i].FirstName) do s2:=s2+' '; For j:=1 To 18-length(Massive[i].FatherName) do s3:=s3+' ';
If not Swop then Writeln('Записей с таким номером группы не обнаружено.');
Writeln;
Line;
Writeln(' |1|...... Повторный поиск'); Writeln(' |0|...... Выход из программы'); Writeln(' |Enter|.. Переход в меню');
Line;
Write('Ваш выбор| ');
Readln(x);
Case x of '1':SearchGroup; '0':halt; Else Menu; End; End;
{Редактирование} Procedure Edit; Var i,j:integer; s1,s2,s3:string; Swop:boolean;
Begin
Clrscr;
Writeln('Редактирование записей базы данных:'); Writeln;
MainTitleEdit;
For i:=1 To n do
Begin
s1:=''; s2:=''; s3:='';
For j:=1 To 18-length(Massive[i].SecondName) do s1:=s1+' '; For j:=1 To 8-length(Massive[i].FirstName) do s2:=s2+' '; For j:=1 To 18-length(Massive[i].FatherName) do s3:=s3+' ';
Write('Введите номер редактируемой записи (укажите [0] для отмены): ');
Readln(i);
If i=0 then
Begin Writeln('Отмена редактирования'); Delay(500); Menu; End;
s1:=''; s2:=''; s3:='';
clrscr;
Writeln('Изменяем:'); For j:=1 To 18-length(Massive[i].SecondName) do s1:=s1+' '; For j:=1 To 8-length(Massive[i].FirstName) do s2:=s2+' '; For j:=1 To 18-length(Massive[i].FatherName) do s3:=s3+' ';
Writeln; Write('Запись успешно отредактирована.'); Delay(1000);
Menu;
End;
{Удаление всех записей}
Procedure DeleteAll; Var f:text; k:char; Begin Writeln; Line; Writeln; Writeln('Вы действительно хотите удалить все данные? [указать "Y" для удаления]'); Write('Ваш выбор| '); Readln(k);
If (k='Y') or (k='y') then Begin Assign(f,'db.txt'); ReWrite(f); Write(''); close(f); Writeln; Write(' Все данные успешно удалены'); Delay(1000); Menu; End; Writeln(' Указан неверный символ'); Delay(500); Writeln(' Переход в меню'); Delay(500); Menu;
End;
{---------------------------------------}
{ ---------------------------- НЕКОРРЕКТНО УДАЛЯЕТ ЗАПИСЬ. УДАЛЯЕТ ДАННЫЕ ИЗ МАССИВА, НО В СТРОКЕ ОСТАЮТСЯ СИМВОЛЫ "|" КОТОРЫЕ РАЗДЕЛЯЮТ КОЛОНКИ }
{Удаление записи}
Procedure Deleting; Var i,j:integer; begin Writeln('Удалить запись с номером: '); readln(i);
Writeln; Write('Запись успешно удалена.'); Delay(1000);
Menu; End;
Procedure Password; Var i,s:integer; Begin n:=5; For i:= 1 To n do Begin clrscr; Writeln('Количество попыток ввода правильного пароля: ', n); Write( 'Введите пароль: ' ); Readln(S); n:=n-1; If S = 1234 then Break Else If i <> 5 then continue; clrscr; goToxy(1,1); Writeln('Количество попыток ввода правильного пароля: 0'); Delay(1000); Writeln( 'Доступ запрещен!'); Delay(2000); Writeln( 'Завершение работы программы...'); Delay(1000); Halt; End; End;
{Меню}
Procedure Menu;
Var option:char;
Begin
clrscr;
ReadAll; Writeln('База данных "Студенты"'); Line; Writeln(' Меню'); Line; Writeln(' |1| Добавление новой записи'); Writeln(' |2| Просмотр записей'); Writeln(' |3| Просмотр записей с сортировкой'); Writeln(' |4| Редактирование записи'); Writeln(' |5| Удаление записи'); Writeln(' |6| Очистить базу данных'); Line; Writeln(' Поиск'); Line; Writeln(' |7| Поиск по фамилии'); Writeln(' |8| Поиск по группе'); Line; Writeln(' |0| Выход из программы'); Line; Write('Ваш выбор| '); Readln(option); Case option of '1':Add; '2':WriteAll; '3':Sort; '4':Edit; '5':Deleting; '6':DeleteAll; '7':SearchSecondName; '8':SearchGroup; '0':halt;
Else Menu; End;
End;
Begin
{Password;}
Menu;
End.
Автор: IUnknown 16.12.2011 23:45
Удалять надо не строки из содержимого ячейки массива, а собственно саму ячейку (сдвигать все содержимое массива на одну позицию влево, начиная от i-той) :
Procedure Deleting; Var i, j:integer; begin Writeln('Удалить запись с номером: '); readln(i); if i <= n then begin Move(Massive[i+1], Massive[i], Sizeof(Database) * (n - i)); dec(n); SaveAll; // ReadAll; Writeln; Write('Запись успешно удалена.'); end else write('Ошибка: неверный номер записи...'); Delay(1000); // Menu; { <--- } End;
(можно было, конечно, передвинуть все элементы массива вручную, обычным циклом, но зачем, если есть процедура, которая делает это сама...)
Как видишь, я внес еще пару изменений в код: для начала - не надо пересчитывать содержимое файла в массив, зачем? Ты ж только что его записал туда... Добавлена так же проверка на ошибку в номере записи (можешь добавить еще проверку на i > 0, чтоб нельзя было ввести нулевых или отрицательных номеров).
Ну, и, наконец - самая большая ошибка: вызов Menu в конце работы процедуры, из этого же Menu вызванной. Не надо этого делать!!!
http://volvo71.narod.ru/menus.htm#menu_errors (здесь я собрал часто встречающиеся ошибки. Так вот, ошибка №2 - это твой случай)
Автор: hemm 17.12.2011 0:29
Большое спасибо, Владимир. Но вот насчет:
Цитата
Ну, и, наконец - самая большая ошибка: вызов Menu в конце работы процедуры, из этого же Menu вызванной. Не надо этого делать!!!
Если убираю допустим после Добавления новой записи (Procedure Add) процедуру Menu, по завершению ввода данных программа завершает свою работу, а не переходит обратно в меню.
И вот если я буду из меню открывать процедуру, а затем опять же возвращаться в меню, в конечном итоге это забьет стек?
Автор: IUnknown 17.12.2011 1:04
Ах, так у тебя и сама процедура Menu неверно написана:
Procedure Menu; Var option: char; Begin ReadAll;
repeat clrscr; Writeln('База данных "Студенты"'); Line; Writeln(' Меню'); Line; Writeln(' |1| Добавление новой записи'); Writeln(' |2| Просмотр записей'); Writeln(' |3| Просмотр записей с сортировкой'); Writeln(' |4| Редактирование записи'); Writeln(' |5| Удаление записи'); Writeln(' |6| Очистить базу данных'); Line; Writeln(' Поиск'); Line; Writeln(' |7| Поиск по фамилии'); Writeln(' |8| Поиск по группе'); Line; Writeln(' |0| Выход из программы'); Line; Write('Ваш выбор| ');
Readln(option); Case option of '1':Add; '2':WriteAll; '3':Sort; '4':Edit; '5':Deleting; '6':DeleteAll; '7':SearchSecondName; '8':SearchGroup; end; until option = '0'; End;
Перед тем, как запускать - убедись, что больше нигде Menu рекурсивно не вызывается. Иначе по первому нажатию "0" не выйдешь изменю, придется нажимать столько раз, сколько было рекурсивных вызовов.
Цитата
И вот если я буду из меню открывать процедуру, а затем опять же возвращаться в меню, в конечном итоге это забьет стек?
Если будешь из Menu вызывать процедуру, а затем, в ее конце - опять вызывать Menu - то да, стек будет заполняться. Если даже не забьешь полностью - то займешь какое-то пространство, которое может пригодиться: стека много не бывает...
Я надеюсь, программа отлаживается в контролем стека? (Options->Compiler->Generated code->Stack checking включено?)
Автор: hemm 17.12.2011 1:31
Фантастика! Благодарю!
Нашел еще одну проблему. Если ввести очень длинную фамилию, то она смещает все данные и таблица нарушается.
{Вывод записей базы данных на экран}
Procedure WriteAll; Var i,j:integer; s1,s2,s3,s4:string;
Begin clrscr;
MainTitle;
For i:=1 To n do
{-------- ВОТ ЗДЕСЬ ПОДСКАЖИТЕ КАК УПРОСТИТЬ} Begin
s1:=''; s2:=''; s3:=''; s4:='';
For j:=1 To 18-length(Massive[i].SecondName) do s1:=s1+' '; For j:=1 To 8-length(Massive[i].FirstName) do s2:=s2+' '; For j:=1 To 18-length(Massive[i].FatherName) do s3:=s3+' '; For j:=1 To 18-length(Massive[i].Group) do s4:=s4+' ';
{ ----------- МОЖНО ЛИ ЗДЕСЬ ОГРАНИЧИТЬ КОЛИЧЕСТВО ВЫВОДИМЫХ СИМВОЛОВ? ПОПЫТАЛСЯ УКАЗАТЬ Massive[i].SecondName: 5, НО ВИДИМО ЭТО ЛИШЬ ДЛЯ ЧИСЕЛ ПОДХОДИТ }
End;
Line;
Writeln; Write(' |Enter|.. Переход в меню'); Readln;
Автор: IUnknown 17.12.2011 2:39
Procedure WriteAll; var i : integer; Begin clrscr; MainTitle; For i:=1 To n do with Massive[i] do begin Writeln( copy(SecondName, 1, 16):18, ' | ', copy(FirstName, 1, 6):8,' | ', copy(FatherName, 1, 16):18, ' | ', copy(Group, 1, 16):18, ' | ', Course ); end; Line; Writeln; Write(' |Enter|.. Переход в меню'); Readln; End;
Теперь какая бы не была фамилия - отобразятся только первые её 16 символов.
Цитата
МОЖНО ЛИ ЗДЕСЬ ОГРАНИЧИТЬ КОЛИЧЕСТВО ВЫВОДИМЫХ СИМВОЛОВ? ПОПЫТАЛСЯ УКАЗАТЬ Massive[i].SecondName: 5, НО ВИДИМО ЭТО ЛИШЬ ДЛЯ ЧИСЕЛ ПОДХОДИТ
Это и для чисел не подходит. Нельзя задать ширину поля меньше, чем нужно для вывода числа:
var i : integer; begin i := 10241; writeln(i:4); end.
не напечатает 1024, будет выведено число полностью.
Автор: IUnknown 17.12.2011 14:02
Итак, от изначальных 715 строк исходного файла в результате нехитрых действий осталось чуть больше 420:
Много кода, поэтому под спойлером(Показать/Скрыть)
Program Students; Uses crt, dos; type DataBase= record SecondName: string; FirstName: string; FatherName: string; Group: string; Course: string; end;
const maxRecords = 50; dbFilename = 'db.txt';
var massive : array[1 .. maxRecords] of DataBase; n : integer;
{Считывание базы данных} procedure ReadAll; var f : text; begin n := 0; Assign(f, dbFilename); {$I-} Reset(f); {$I+}
if IOResult <> 0 then Writeln('Ошибка: невозможно открыть исходный файл. Повторите ввод.') else begin while not EOF(f) do begin inc(n); Readln(f, Massive[n].SecondName); Readln(f, Massive[n].FirstName); Readln(f, Massive[n].FatherName); Readln(f, Massive[n].Group); Readln(f, Massive[n].Course); Readln(f); end; close(f); end; end;
{Сохранение отредактированной базы данных в файл} procedure SaveAll; var i : integer; f : text; Begin Assign(f, dbFilename); Rewrite(f); for i := 1 To n do begin Writeln(f, Massive[i].SecondName); Writeln(f, Massive[i].FirstName); Writeln(f, Massive[i].FatherName); Writeln(f, Massive[i].Group); Writeln(f, Massive[i].Course); Writeln(f); end; close(f); end;
{Добавление записи} procedure Add; begin Clrscr; inc(n); Writeln('Добавление новой записи о студенте:'); Writeln; InputRec(Massive[n]); SaveAll; Writeln; Write('Запись успешно добавлена в базу данных'); Delay(1000); end;
{Вывод записей базы данных на экран} procedure WriteAll; var i : integer; begin ClrScr; MainTitle; For i := 1 To n do PrintRec(Massive[i]); Line; Writeln; Write(' |Enter|.. Переход в меню'); Readln; end;
{Вывод записей базы данных с сортировкой на экран} procedure Sort;
function Exchange(Var A, B : Database) : boolean; var T : Database; begin T := A; A := B; B := T; Exchange := true; end;
var i, nn : integer; Xchanged : boolean; begin ClrScr;
nn := n; repeat Xchanged := false; for i := 1 to nn - 1 do begin if Massive[i].SecondName > Massive[i+1].SecondName then Xchanged := Exchange(Massive[i], Massive[i+1]); end; nn := nn-1; until not Xchanged; MainTitle; WriteAll; Line; End;
{Поиск по фамилии} procedure SearchSecondName; var SN : string; i : integer; Found : boolean; x : char; begin Clrscr; SearchTitle; Write('Введите фамилию студента: '); Readln(SN); Writeln; Found := false; MainTitle;
for i := 1 to n do if Massive[i].SecondName = SN then Found := PrintRec(Massive[i]);
Line; if not Found then Writeln('Записей с такой фамилией не обнаружено либо имя указано неверно'); Writeln; Line; Writeln(' |1|...... Повторный поиск'); Writeln(' |0|...... Выход из программы'); Writeln(' |Enter|.. Переход в меню'); Line; Write('Ваш выбор| '); Readln(x); case x of '1' : SearchSecondName; '0' : Halt; end; end;
{Поиск по группе} procedure SearchGroup; var SG : string; i : integer; Found : boolean; x : char; begin ClrScr; SearchTitle; Write('Введите номер группы: '); Readln(SG); Writeln; Found := false; MainTitle;
for i := 1 to n do if Massive[i].Group = SG then Found := PrintRec(Massive[i]);
Line; if not Found then Writeln('Записей с таким номером группы не обнаружено.'); Writeln; Line; Writeln(' |1|...... Повторный поиск'); Writeln(' |0|...... Выход из программы'); Writeln(' |Enter|.. Переход в меню'); Line; Write('Ваш выбор| '); Readln(x); case x of '1' : SearchGroup; '0' : Halt; end; end;
{Редактирование} procedure Edit; var i : integer; begin Clrscr; Writeln('Редактирование записей базы данных:'); Writeln; MainTitleEdit; for i := 1 to n do begin Write(i:2, '.'); PrintRec(Massive[i]); end;
Writeln; Write('Введите номер редактируемой записи (укажите [0] для отмены): '); Readln(i); if i = 0 then begin Writeln('Отмена редактирования'); Delay(500); end else begin clrscr; Writeln('Изменяем:'); MainTitleEdit; Write(i:2, '.'); PrintRec(Massive[i]); Writeln; Writeln('Введите новые данные:'); InputRec(Massive[i]);
SaveAll; ReadAll; Writeln; Write('Запись успешно отредактирована.'); Delay(1000); end; end;
{Удаление всех записей} procedure DeleteAll; var f : text; k : char; begin Writeln; Line; Writeln; Writeln('Вы действительно хотите удалить все данные? [указать "Y" для удаления]'); Write('Ваш выбор| '); Readln(k); If k in ['Y', 'y'] then begin Assign(f, dbFilename); ReWrite(f); Write(''); // o_O close(f); Writeln; Write(' Все данные успешно удалены'); Delay(1000); end else begin Writeln(' Указан неверный символ'); Delay(500); Writeln(' Переход в меню'); Delay(500); end; end;
{Удаление записи} procedure Deleting; var i : integer; begin Writeln('Удалить запись с номером: '); Readln(i); if i <= n then begin Move(Massive[i+1], Massive[i], Sizeof(Database) * (n - i)); dec(n); SaveAll; Writeln; Write('Запись успешно удалена.'); end else write('Ошибка: неверный номер записи...'); Delay(1000); end;
procedure Password; var i, s : integer; Attempts : Integer; begin Attempts := 5; for i := 1 to Attempts do begin clrscr; Writeln('Количество попыток ввода правильного пароля: ', n); Write( 'Введите пароль: ' ); Readln(S); if S = 1234 then break else if i <> Attempts then continue;
{Меню} procedure Menu; var option: char; begin ReadAll;
repeat clrscr; Writeln('База данных "Студенты"'); Line; Writeln(' Меню'); Line; Writeln(' |1| Добавление новой записи'); Writeln(' |2| Просмотр записей'); Writeln(' |3| Просмотр записей с сортировкой'); Writeln(' |4| Редактирование записи'); Writeln(' |5| Удаление записи'); Writeln(' |6| Очистить базу данных'); Line; Writeln(' Поиск'); Line; Writeln(' |7| Поиск по фамилии'); Writeln(' |8| Поиск по группе'); Line; Writeln(' |0| Выход из программы'); Line; Write('Ваш выбор| ');
Readln(option); case option of '1':Add; '2':WriteAll; '3':Sort; '4':Edit; '5':Deleting; '6':DeleteAll; '7':SearchSecondName; '8':SearchGroup; end; until option = '0'; end;
begin Password; Menu; end.
Можно еще покумекать над объединением двух процедур поиска в одну (я где-то на форуме выкладывал пример, если не ошибаюсь, надо будет поискать). Также стоит подумать над вынесением часто повторяющихся
Write('bla-bla-bla'); Delay(...);
в отдельную процедуру. В общем, заготовка у тебя есть, допиливай
Автор: -TarasBer- 17.12.2011 14:13
Спойлер(Показать/Скрыть)
> (можно было, конечно, передвинуть все элементы массива вручную, обычным циклом, но зачем, если есть процедура, которая делает это сама...)
От тебя не ожидал.
Автор: IUnknown 17.12.2011 14:48
Спойлер(Показать/Скрыть)
Цитата
От тебя не ожидал.
Что-то не так? Что, надо было перенести последний элемент на место удаляемого, чтоб поменять порядок следования записей? Или ты действительно думаешь, что вручную написанный цикл будет выполняться быстрее, чем Move? Не будет. Да и не собираюсь я каждый раз заново писать код, который уже написан, отлажен и присутствует в RTL - у меня более интересные занятия есть.
Где можно использовать Array Slices - я их использую. FPC/TP этого не позволяют, поэтому Move...
Автор: hemm 17.12.2011 22:57
Допилил. Все работает как надо.
Единственное, что при редактировании (если в базе больше 10 записей) нельзя прокрутить и посмотреть первые.
Получается такая штука:
Спойлер(Показать/Скрыть)
Program Students; Uses crt, dos; type DataBase= record SecondName: string; FirstName: string; FatherName: string; Group: string; Faculty: string; Number: string; End;
const maxRecords = 999; dbFilename = 'db.txt';
Var massive : array[1 .. maxRecords] of DataBase; n : integer;
{Считывание базы данных} Procedure ReadAll; Var f : text; Begin n := 0; Assign(f, dbFilename); {$I-} Reset(f); {$I+}
if IOResult <> 0 then Writeln('Ошибка: невозможно открыть исходный файл. Повторите ввод.') else Begin while not EOF(f) do Begin inc(n); Readln(f, Massive[n].SecondName); Readln(f, Massive[n].FirstName); Readln(f, Massive[n].FatherName); Readln(f, Massive[n].Group); Readln(f, Massive[n].Faculty); Readln(f, Massive[n].Number); Readln(f); End; close(f); End; End;
{Линия} Procedure Line; Var k : integer; Begin for k := 1 to 79 do write('-'); Writeln; End;
{Сохранение отредактированной базы данных в файл} Procedure SaveAll; Var i : integer; f : text; Begin Assign(f, dbFilename); Rewrite(f); for i := 1 To n do Begin Writeln(f, Massive[i].SecondName); Writeln(f, Massive[i].FirstName); Writeln(f, Massive[i].FatherName); Writeln(f, Massive[i].Group); Writeln(f, Massive[i].Faculty); Writeln(f, Massive[i].Number); Writeln(f); End; close(f); End;
{Ограничение на количество выводимых символов в таблице} Function PrintRec(const Rec : Database) : boolean; Begin With Rec do Writeln( Copy(SecondName, 1, 15):16, '|', Copy(FirstName, 1, 13):14,'|', Copy(FatherName, 1, 13):14, '|', Copy(Group, 1, 7):8, '|', Copy(Faculty, 1,8):9, '|', Copy(Number, 1,7):8 ); Line; PrintRec := true;
End;
Procedure InputRec(Var Rec : Database); Begin with Rec do Begin Write('Фамилия........: '); Readln(SecondName); Write('Имя............: '); Readln(FirstName); Write('Отчество.......: '); Readln(FatherName); Write('Номер группы...: '); Readln(Group); Write('Факультет......: '); Readln(Faculty); Write('Номер билета...: '); Readln(Number); End; End;
{Оглавление процедуры поиска} Procedure SearchTitle; Begin Writeln('Поиск'); Writeln; End;
{Оглавление} Procedure MainTitle; Begin Line; Write(' Фамилия |'); Write(' Имя |'); Write(' Отчество |'); write(' Группа |'); Write(' Фак-тет |'); Write(' Билет '); Writeln; Line;
End;
{Вывод записей базы данных на экран} Procedure WriteAll; Var i : integer; Begin ClrScr; MainTitle; For i := 1 To n do PrintRec(Massive[i]);
Writeln; Write(' |Enter|.. Переход в меню'); Readln; End;
{Вывод записей базы данных с сортировкой на экран} Procedure Sort;
function Exchange(Var A, B : Database) : boolean; Var T : Database; Begin T := A; A := B; B := T; Exchange := true; End;
Var i, nn : integer; Xchanged : boolean; Begin ClrScr;
nn := n; repeat Xchanged := false; for i := 1 to nn - 1 do Begin if Massive[i].SecondName > Massive[i+1].SecondName then Xchanged := Exchange(Massive[i], Massive[i+1]); End; nn := nn-1; until not Xchanged; MainTitle; WriteAll; End;
{Поиск по фамилии} Procedure SearchSecondName; Var SSN : string; i : integer; Found : boolean; x : char; Begin Clrscr; SearchTitle; Write('Введите фамилию студента: '); Readln(SSN); Writeln; Found := false; MainTitle;
for i := 1 to n do if Massive[i].SecondName = SSN then Found := PrintRec(Massive[i]); if not Found then Writeln('Записей с такой фамилией не обнаружено.'); Writeln; Writeln(' |1|...... Повторный поиск'); Writeln(' |0|...... Выход из программы'); Writeln(' |Enter|.. Переход в меню'); Writeln; Write('Ваш выбор| '); Readln(x); case x of '1' : SearchSecondName; '0' : Halt; End; End;
{Поиск по группе} Procedure SearchGroup; Var SG : string; i : integer; Found : boolean; x : char; Begin ClrScr; SearchTitle; Write('Введите номер группы: '); Readln(SG); Writeln; Found := false; MainTitle;
for i := 1 to n do if Massive[i].Group = SG then Found := PrintRec(Massive[i]); if not Found then Writeln('Записей с таким номером группы не обнаружено.'); Writeln; Writeln(' |1|...... Повторный поиск'); Writeln(' |0|...... Выход из программы'); Writeln(' |Enter|.. Переход в меню'); Writeln; Write('Ваш выбор| '); Readln(x); case x of '1' : SearchGroup; '0' : Halt; End; End;
{Поиск по номеру билета} Procedure SearchNumber;
Var SN : string; i : integer; Found : boolean; x : char; Begin Clrscr; SearchTitle; Write('Введите номер билета: '); Readln(SN); Writeln; Found := false; MainTitle;
for i := 1 to n do if Massive[i].Number = SN then Found := PrintRec(Massive[i]); if not Found then Writeln('Записей с таким номером билета не обнаружено'); Writeln; Writeln(' |1|...... Повторный поиск'); Writeln(' |0|...... Выход из программы'); Writeln(' |Enter|.. Переход в меню'); Writeln; Write('Ваш выбор| '); Readln(x); case x of '1' : SearchNumber; '0' : Halt; End; End;
{Оглавление редактирования} Procedure MainTitleEdit; Begin
Line; write(' # |'); Write(' Фамилия |'); Write(' Имя |'); Write(' Отчество |'); write(' Группа |'); Write(' Фак-тет |'); Write(' Билет '); Writeln; Line; End;
{Редактирование} Procedure Edit; Var i : integer; Begin Clrscr; Writeln('Редактирование'); Writeln; MainTitleEdit; for i := 1 to n do Begin Write(i:4, '.'); PrintRec(Massive[i]); End;
Writeln; Write('Введите номер редактируемой записи (укажите [0] для отмены / выхода в меню): '); Readln(i); if i = 0 then Begin End else Begin clrscr; Writeln('Изменяем:'); MainTitle; PrintRec(Massive[i]); Writeln; Writeln('Введите новые данные:'); InputRec(Massive[i]);
SaveAll; ReadAll; Writeln; Write('Запись успешно отредактирована.'); Delay(1000); Edit; End; End;
{Удаление записи} Procedure DeleteRecord; Var i : integer;
Begin Clrscr; Writeln('Удаление'); Writeln;
MainTitleEdit; for i := 1 to n do Begin Write(i:4, '.'); PrintRec(Massive[i]); End;
Writeln;
Write('Удалить запись с номером (укажите [0] для отмены / выхода в меню): '); Readln(i); if i=0 then Begin end else if i <= n then Begin Move(Massive[i+1], Massive[i], Sizeof(Database) * (n - i)); dec(n); SaveAll; Writeln; Write('Запись успешно удалена!'); DeleteRecord; End else write('Ошибка: неверный номер записи...'); Delay(500); End;
Procedure Password; Var i: integer; User, Pass: string; Attempts : Integer; Begin Attempts := 1; for i := 5 downto Attempts do Begin
if (User = 'Дроздов') And (Pass='АСОИ') then break else if i <> Attempts then continue; clrscr; textbackground(7); textcolor(4); Delay(500); Writeln( 'Доступ запрещен!'); Delay(500); Write( 'Завершение работы программы!'); Delay(1000); textbackground(8); textcolor(15); Halt; End; End;
{Меню} Procedure Menu; Var option: char; Begin ReadAll; repeat clrscr; textbackground(7); textcolor(0); Writeln(' База данных "Студенты" '); textbackground(8); textcolor(15);
textbackground(7); textcolor(0); Writeln; Writeln(' Меню '); Writeln; textbackground(8); textcolor(15); Writeln(' |1| Добавление новой записи'); Writeln(' |2| Просмотр записей'); Writeln(' |3| Просмотр записей с сортировкой по фамилии'); Writeln(' |4| Редактирование записи'); Writeln(' |5| Удаление записи'); Writeln; textbackground(7); textcolor(0); Writeln(' Поиск '); textbackground(8); textcolor(15); Writeln; Writeln(' |6| Поиск по фамилии'); Writeln(' |7| Поиск по группе'); Writeln(' |8| Поиск по номеру билета'); Writeln; textbackground(7); textcolor(0); Writeln(' Выход '); textbackground(8); textcolor(15); Writeln; Writeln(' |9| Выход к меню ввода пароля'); Writeln(' |0| Выход из программы'); Writeln; textbackground(7); textcolor(0); Write('Ваш выбор |'); textbackground(8); textcolor(15); write(' '); Readln(option); case option of '1':Add; '2':WriteAll; '3':Sort; '4':Edit; '5':DeleteRecord; '6':SearchSecondName; '7':SearchGroup; '8':SearchNumber; '9':Password; End; until option = '0'; End; Begin Password; Menu; End.
Автор: IUnknown 17.12.2011 23:02
Прокрутку я тоже как-то показывал на форуме, поищи.