/ КОМПЬЮТЕРЫ И ПО / Языки программирования / Pascal

Выпуск № 403
от 18.06.2007, 12:05

Вопрос № 91.060

Уважаемые эксперты, помогите написать процедуру для базы данных работников. Процедура должна, по запросу выдавать сообщение есть ли у кого из работников сегодня день рождение, если есть, то на экран выводятся данные этих работников, иначе сообщение: Дня рожденья нет! Приложение: program name; uses wincrt; const m='baza.txt'; m2='baza2.txt'; type rab=record fam,im,ot:string[15]; day,mon,ye:integer; adr:string[22]; tel:string[15]; god:string[15]; dr:string[15]; aj:byte; end; var kl,kl2:file of rab; n,k:rab; i:word; ind:word; den,mes:word; godp:integer; procedure vvod(var ind:word); var i,j:byte; begin assign(kl,m); rewrite(kl); Writeln('Введите количество работников.'); readln(i); ind:=i; n.tel:=''; for j:=1 to i do begin writeln('Введите данные о работнике.'); writeln('Работник № ',j); write('Введите фамилию: '); readln(n.fam); write('Введите имя: '); readln(n.im); write('Введите отчество: '); readln(n.ot); write('Введите дату рождения (дд.мм.гггг.): '); readln(n.dr); write('Введите адрес (ул.дом.кв): ');readln(n.adr); write('Введите телефон: ');readln(n.tel); write('Введите год поступ. на работу:');write(' Число: '); readln(n.day); write(' Месяц: '); readln(n.mon); write(' Год: '); readln(n.ye); write('Введите общий стаж (лет): '); readln(n.aj); write(kl,n); end; close(kl); end; procedure printk; var i:word; begin assign(kl,m); {$I-} reset(kl); if ioresult <>0 then writeln('Файл не существует') else begin {$I+} writeln('№ Фамилия Имя Отчество Д/р '); i:=0; while not eof(kl) do begin i:=i+1; read(kl,n); write(i:1); with n do begin write(fam:15);write(im:8);write(ot:15); {фио} write(dr:15);{дата рожд.} writeln; writeln; writeln(' Адрес Телефон Год приема Пед. стаж '); write(adr:15);{адрес} write(tel:9);{телефон} write(day:3);write(mon:3);write(ye:6);{год поступ.} writeln(aj:9);{стаж} writeln; writeln('-------------------------------------------------------'); end; end; close(kl); end; end; procedure dob; begin n:=k; assign(kl,m); {$I-} reset(kl); if ioresult <>0 then begin writeln('Файл не существует');exit end; {$I+} seek(kl,filesize(kl)); writeln('Введите добавляемую запись'); write('Введите фамилию: '); readln(n.fam); write('Введите имя: '); readln(n.im); write('Введите отчество: '); readln(n.ot); write('Введите дату рождения (дд.мм.гггг.): '); readln(n.dr); write('Введите адрес (ул.дом.кв): ');readln(n.adr); write('Введите телефон: ');readln(n.tel); write('Введите год поступ. на работу (дд.мм.гггг.): '); readln(n.god); writeln('Введите общий стаж (лет): ');readln(n.aj); write(kl,n); end; procedure izm; var a,j:word; begin assign(kl,m); {$I-} reset(kl); write('Введите номер работника, которого надо изменить: '); readln(j); seek(kl,j-1); read(kl,n); with n do begin write(fam:11);write(im:10);write(ot:13); {фио} write(dr:12);{дата рожд.} write(adr:17);{адрес} write(tel:6);{телефон} write(god:11);{год поступ.} writeln(aj:2);{стаж} end; seek(kl,j-1); write('Введите фамилию: '); readln(n.fam); write('Введите имя: '); readln(n.im); write('Введите отчество: '); readln(n.ot); write('Введите дату рождения (дд.мм.гггг.): '); readln(n.dr); write('Введите адрес: ');readln(n.adr); write('Введите телефон: ');readln(n.tel); write('Введите год поступ. на работу (дд.мм.гггг.): '); readln(n.god); write('Введите общий стаж (лет): '); readln(n.aj); writeln; write(kl,n); close(kl); end; procedure zapr; begin writeln('Работники, у которых нет телефона'); assign(kl,m); {$I-} if ioresult<>0 then writeln('Файла нет!') else reset(kl);{$I+} while not eof(kl) do begin read(kl,n); if length(n.tel)=0 then begin with n do begin write(fam:15);write(im:15);write(ot:15); {фио} write(dr:15);{дата рожд.} write(adr:22);{адрес} write(god:15);{год поступ.} writeln(aj);{стаж} end; end; end; close(kl); end; procedure del; var w:byte; begin assign(kl,m); {$I-} reset(kl); if ioresult<>0 then begin writeln('Файл не существует!'); exit end; {$I+} assign(kl2,m2); rewrite(kl2); write('Введите номер записи, которую следует удалить: '); readln(w); if w>filesize(kl) then begin writeln('Нет записи с таким номером!'); exit end; while not eof(kl) do begin if (w=filesize(kl))and(filepos(kl)=w-1) then break; if filepos(kl)=w-1 then seek(kl,w); read(kl,n); write(kl2,n); end; close(kl); rewrite(kl); seek(kl2,0); while not eof(kl2) do begin read(kl2,n); write(kl,n); end; close(kl2); close(kl); writeln('Запись удалена!'); writeln; end; begin writeln('---Вас приветствует база данных работников УК КЭФ---'); begin write('Введите дату:');write(' Число: ');readln(den); write(' Месяц: ');readln(mes); write(' Год: ');readln(godp); end; Writeln; repeat writeln; Writeln('---Меню программы---'); writeln('1-Ввести спиок'); writeln('2-Вывести весь список'); writeln('3-Добавить запись'); writeln('4-Изменить данные работника'); writeln('5-Удаление записи'); writeln('6-Запросы'); readln(i); case i of 1:vvod(ind); 2:printk; 3:dob; 4:izm; 6:zapr; 5:del; end; until i=0; end.

Отправлен: 12.06.2007, 12:09 Вопрос задал: Pahar (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Градов Юрий Михайлович Здравствуйте, Eisenheim! Добавить в Ваше меню 7 пункт и написать процедуру: ....... writeln('7-Запрос дня рождения'); readln(i); case i of 1:vvod(ind); 2:printk; 3:dob; 4:izm; 6:zapr; 5:del; 7:Birthday; end; until i=0; Приложение: procedure Birthday; var s: string; bd: boolean; begin bd:=False; Writeln('Введите дату (дд.мм.гггг)'); Read(s); writeln('Работники, у которых дни рождения'); assign(kl,m); {$I-} if IoResult<>0 then begin writeln('Файла нет!'); Exit; end else reset(kl); {$I+} while not eof(kl) do begin read(kl,n); if n.dr=s then begin with n do begin bd:=True; write(fam:15);write(im:15);write(ot:15); {фио} write(dr:15);{дата рожд.} write(adr:22);{адрес} write(god:15);{год поступ.} writeln(aj);{стаж} end; end; end; if bd=False then Writeln('Дней рождения нет!'); close(kl); end; --------- Глаза боятся - руки делают!

Ответ отправил: Градов Юрий Михайлович (статус: Студент) Ответ отправлен: 12.06.2007, 13:13 Оценка за ответ: 5 Комментарий оценки: Спасибо большое за квалифицированный ответ!

Вопрос № 91.070

Здраствуйте эксперты помогите решить задачу: Найти сумму элементов массива A[10], больших 3 и меньших 8 и вывести ее на экран. Элементы массива вводятся с клавиатуры. Очень срочно, пожалуйста! [Проведена корректировка вопроса, после уточнения в мини-форуме] [Edited by Gh0stik]

Отправлен: 12.06.2007, 13:27 Вопрос задал: Паснов Максим Александрович (статус: Посетитель) Всего ответов: 3 Мини-форум вопроса >>> (сообщений: 6)

Отвечает: Ерёмин А.А. Здравствуйте, Паснов Максим Александрович! См. приложение. Заполнение массива производится случайным образом. Приложение: program Q91070; uses Crt; var A: array[1..10] of integer; i,s: integer; begin clrscr; Randomize; writeln('A:'); for i:=1 to 10 do begin A[i]:=Random(10); Writeln('A[',i,'] => ',A[i]) end; Writeln; s:=0; for i:=1 to 10 do if (A[i] > 3) and (A[i] < 8) then Inc(S,A[i]); Writeln('Sum = ',S); readln; end. --------- Нет правила без исключений. Правило без исключений - исключение из правил.

Ответ отправил: Ерёмин А.А. (статус: Академик) Россия, Тула WWW: Программирование на DELPHI ---- Ответ отправлен: 12.06.2007, 13:45

Отвечает: Градов Юрий Михайлович Здравствуйте, Паснов Максим Александрович! К сожалению Вы не написали сумму каких элементов и чего, но посмотрите это решение: Приложение: var Mass: array[1..10,1..10] of integer; i,j,sum: integer; begin ClrScr; sum:=0; for i:=1 to 10 do begin for j:=1 to 10 do begin Mass[i,j]:=Random(10); Write(Mass[i,j],' '); end; Writeln; end; for i:=1 to 10 do for j:=1 to 10 do if (Mass[i,j]>3) and (Mass[i,j]<8) then sum:=sum+Mass[i,j]; Writeln; Write('Obshchaya summa elementov >3 i <8 = '); Write(sum); ReadKey; end. --------- Глаза боятся - руки делают!

Ответ отправил: Градов Юрий Михайлович (статус: Студент) Ответ отправлен: 12.06.2007, 14:06

Отвечает: Gh0stik Здравствуйте, Паснов Максим Александрович! Приведу немного упрощенный вариант ответа, поскольку сумму можно считать и при введении массива с клавиатуры (задача решается в один проход). var a:[1..10] of real; i:integer; s:real; begin s:=0; for i:=1 to 10 do begin write('a[',i,']='); read(a[i]); if (a[i] > 3) and (a[i] < 8) then s:=s+a[i]; end; write('sum=',s:6:3); end. Good Luck!!! --------- Господь Бог - это всего лишь сверхмощный генератор случайных чисел, в соответствии с которыми сочетаются события на Земле. Генератор случайных чисел - и только.

Ответ отправил: Gh0stik (статус: Профессор) Украина, Славянск Организация: Славянский государственный педагогический университет (Кафедра алгебры) ICQ: 289363162 ---- Ответ отправлен: 13.06.2007, 01:35

Вопрос № 91.073

Помогите: Даны файл, содержащий текст на русском языке, и некоторая буква. Подсчитать, сколько слов начинается с указанной буквы.

Отправлен: 12.06.2007, 13:55 Вопрос задал: Артем Фурдыга (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Градов Юрий Михайлович Здравствуйте, Артем Фурдыга! В условии Вы написали, что уже имеется файл. Если такового нет, то в Блокноте откройте любой текстовый файл и сохраните в папку с этой программой с именем test.txt Приложение: var F: text; st: string; s: Char; count: integer; i: integer; function LowerCase(s: string): string; var i: integer; begin result := s; for i := 1 to length(result) do if (result[i] in ['A'..'Z', 'А'..'Я']) then result[i] := chr(ord(result[i]) + 32); end; function LoCase(ch: char): char; begin if (ch in ['A'..'Z', 'А'..'Я']) then result := chr(ord(ch) + 32) else result := ch; end; begin ClrScr; Write('Vvedite proverochuyu bukvu - '); Read(s); s:=LoCase(s); Assign(F,'test.txt'); Reset(F); Count:=0; While not Eof(F) do begin Writeln(F,St); St:=LowerCase(St); if St[i]=s then Inc(count); for i:=2 to Length(St)-1 do if St[i]=' ' then begin if St[i+1]=s then Inc(Count); end; end; Write('Bukva',s); Write(' v nachale slova vstrechaetsya ',count); Write(' raz'); end. --------- Глаза боятся - руки делают!

Ответ отправил: Градов Юрий Михайлович (статус: Студент) Ответ отправлен: 12.06.2007, 15:18

Вопрос № 91.157

Здравствуйте. Помогите пожалуйста решить задачу: Пусть дан текстовый файл. Для каждой строки распечатайте первое из слов, содержащих наибольшее число различных букв.

Отправлен: 12.06.2007, 23:26 Вопрос задал: Максим Сергеевич (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 2)

Отвечает: Левадный Тимур Русланович Здравствуйте, Максим Сергеевич! Смотрите код в приложении. Код исправлен по просьбе автора ответа. [ Alexandre V. Tchamaev ] Приложение: program q91157; uses crt; var s,w:string; f:text; function word:integer; {ищем количество различных букв} var i,j,rez:integer; c:char; begin rez:=length(w); for i:=1 to length(w) do begin c:=w[i]; for j:=i+1 to length(w) do if (c=w[j])and(i<>j) then rez:=rez-1; end; word:=rez; end; function find:string; {разбиваем строку на слова} var i,max,n:integer; begin w:=''; max:=0; for i:=1 to length(s) do if s[i] in ['A'..'Z','a'..'z'] then w:=w+s[i] else begin n:=word; if n>max then find:=w; w:='' end; n:=word; if n>max then find:=w; end; begin clrscr; {$I-} assign(f,'text.txt'); reset(f); {$I+} if IOresult<>0 then write('error') else while not eof(f) do begin readln(f,s); writeln(find); end; readkey; end.

Ответ отправил: Левадный Тимур Русланович (статус: 1-ый класс) Ответ отправлен: 13.06.2007, 11:49

Вопрос № 91.202

Уважаемые эксперты! Помогите пожалуйста разобраться с применением формальных и фактических параметров при вызове процедуры с параметром- переменной: типизированный файл типа record. Выдает ошибку о несоответствии типов формальных и фактических параметров. Заранее благодарен Приложение: program z1_01; uses crt; const n=15; type tprod= record tgost: word; tlogo: string[10]; tves_izd: real; tvis_gorl: string[10]; ttol_st: real; tvis_sbr: real; tves_obl: string[15]; tcycle: string[10]; end; var kol,sel: integer; fp: file of tprod; dbname: string[20]; {Проверка наличия файлов на диске} function ff(naim:string):boolean; var fil:file of tprod; begin {$I-} assign(fil,naim); reset(fil); close(fil); {$I+} ff:=(IOResult<>0) end; {Ввод данных с клавиатуры} procedure data_input(var fp:tprod); {Процедура-заглушка} begin writeln('Ввод данных в БД еще не реализован'); writeln('Нажмите <Enter> для продолжения'); readln end; ... {Основная программа} Begin TextBackGround (blue); TextColor (yellow); ClrScr; dbname:='c:dbase.dat'; if ff(dbname) then data_input(fp); ...

Отправлен: 13.06.2007, 10:56 Вопрос задал: D2alex (статус: Посетитель) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Зенченко Константин Николаевич Здравствуйте, D2alex! fp:file of tprod;-Вы определяете переменную как указатель на файл и передаете ее в подпрограмму (переменная программы); procedure data_input(var fp:tprod);-Вы определяете переменную как запись, что не соответсвует передаваимым данным (переменная подпрограммы). Обе переменные нужно привести к одному типу. Удачи! --------- И только наступив на грабли мы преобретаем драгоценный опыт!

Ответ отправил: Зенченко Константин Николаевич (статус: Практикант) Ответ отправлен: 13.06.2007, 11:24

Отвечает: Градов Юрий Михайлович Здравствуйте, D2alex! Вы вызываете процедуру по типу файла - необходимо по имени файла. --------- Глаза боятся - руки делают!

Ответ отправил: Градов Юрий Михайлович (статус: Студент) Ответ отправлен: 13.06.2007, 11:30

© 2001-2007, Портал RusFAQ.ru, Россия, Москва. Авторское право: ООО "Мастер-Эксперт Про" Email: support@rusfaq.ru, тел.: +7 (926) 535-23-31 Хостинг: "Московский хостер" Поддержка: "Московский дизайнер" Авторские права | Реклама на портале Версия системы: 4.52 от 02.05.2007
RusFAQ.ru | MosHoster.ru | MosDesigner.ru | RusIRC.ru Kalashnikoff.ru | RadioLeader.ru | RusFUCK.ru