Навигация
Главная
Поиск
Форум
FAQ's
Ссылки
Карта сайта
Чат программистов

Статьи
-Delphi
-C/C++
-Turbo Pascal
-Assembler
-Java/JS
-PHP
-Perl
-DHTML
-Prolog
-GPSS
-Сайтостроительство
-CMS: PHP Fusion
-Инвестирование

Файлы
-Для программистов
-Компонеты для Delphi
-Исходники на Delphi
-Исходники на C/C++
-Книги по Delphi
-Книги по С/С++
-Книги по JAVA/JS
-Книги по Basic/VB/.NET
-Книги по PHP/MySQL
-Книги по Assembler
-PHP Fusion MOD'ы
-by Kest
Professional Download System
Реклама
Услуги

Автоматическое добавление статей на сайты на Wordpress, Joomla, DLE
Заказать продвижение сайта
Программа для рисования блок-схем
Инженерный калькулятор онлайн
Таблица сложения онлайн
Популярные статьи
OpenGL и Delphi... 65535
Форум на вашем ... 65535
HACK F.A.Q 65535
Бип из системно... 65535
Гостевая книга ... 65535
Invision Power ... 65535
Содержание сайт... 65535
Организация зап... 65535
Вызов хранимых ... 65535
Программируемая... 65535
Эмулятор микроп... 65535
Подключение Mic... 65535
Создание потоко... 65535
Приложение «Про... 65535
Оператор выбора... 65535
Создание отчето... 63258
Модуль Forms 63162
ТЕХНОЛОГИИ ДОСТ... 59801
Пример работы с... 58670
Имитационное мо... 55277
Реклама
Сейчас на сайте
Гостей: 11
На сайте нет зарегистрированных пользователей

Пользователей: 13,075
новичок: JleoN
Новости
Реклама
Выполняем курсовые и лабораторные по разным языкам программирования
Подробнее - курсовые и лабораторные на заказ
Delphi, Turbo Pascal, Assembler, C, C++, C#, Visual Basic, Java, GPSS, Prolog, 3D MAX, Компас 3D
Заказать программу для Windows Mobile, Symbian

Информационная система - транспортный парк на Turbo Pascal (База данных)...
Моделирование автовокзала + Отчет + Блок схема
Моделирование интернет кафе на GPSS + Отчет

Реклама



Подписывайся на YouTube канал о программировании, что бы не пропустить новые видео!

ПОДПИСЫВАЙСЯ на канал о программировании
База данных на паскале 2
GrMenu.pas - модуль меню
unit GrMenu;
interface
uses Graph,crt;
procedure Menu;
procedure SubMenu;
procedure ButtonGraph(param:byte);
procedure SubMenuButtonGraph(param:byte);
var KeyCount:byte;
implementation
procedure Menu;
var Xpos1,Xpos2,Xpos3,i:integer;
begin
cleardevice;
setcolor(1);
Xpos1:=10;
Xpos2:=47;
for i:=1 to 7 do
begin
rectangle(Xpos1,10,Xpos2,20);
Xpos1:=Xpos1+85;
Xpos2:=Xpos2+85;
end;
setcolor(2);
outtextxy(11,12,'add');
outtextxy(96,12,'show');
outtextxy(181,12,'save');
outtextxy(266,12,'sort');
outtextxy(351,12,'read');
outtextxy(438,12,'del');
outtextxy(521,12,'exit');
end;
procedure SubMenu;
var i,Xpos1:integer;
begin
setcolor(2);
Xpos1:=100;
line(280,20,280,35);
setlinestyle(0,0,1);
line(100,35,450,35);
for i:=1 to 8 do
begin
setcolor(2);
line(Xpos1,35,Xpos1,50);
setcolor(1);
rectangle(Xpos1-15,50,Xpos1+15,60);
Xpos1:=Xpos1+50;
end;
setcolor(2);
outtextxy(90,52,'A');
outtextxy(140,52,'B');
outtextxy(190,52,'C');
outtextxy(240,52,'D');
outtextxy(290,52,'E');
outtextxy(340,52,'F');
outtextxy(390,52,'G');
outtextxy(440,52,'esk');
end;
procedure ButtonGraph;
var FloodX,TextX:integer;text:string;
begin
setfillstyle(1,2);
if KeyCount>16 then KeyCount:=16;
if KeyCount<10 then KeyCount:=10;
case param of
10:begin
FloodX:=11;
TextX:=11;
text:='add';end;
11:begin
FloodX:=96;
TextX:=96;
text:='show';end;
12:begin
FloodX:=181;
TextX:=181;
text:='save';end;
13:begin
FloodX:=266;
TextX:=266;
text:='sort';end;
14:begin
FloodX:=351;
TextX:=351;
text:='read';end;
15:begin
FloodX:=436;
TextX:=438;
text:='del';end;
16:begin
FloodX:=521;
TextX:=521;
text:='exit';end;
end;
Menu;
floodfill(FloodX,18,1);
setcolor(0);
outtextxy(TextX,12,text);
end;
procedure SubMenuButtonGraph;
var FloodX,TextX:integer;text:string;
begin
if KeyCount>17 then KeyCount:=17;
if KeyCount<10 then KeyCount:=10;
case param of
10:begin
FloodX:=101;
TextX:=90;
text:='A';end;
11:begin
FloodX:=141;
TextX:=140;
text:='B';end;
12:begin
FloodX:=191;
TextX:=190;
text:='C';
end;
13:begin
FloodX:=241;
TextX:=240;
text:='D';
end;
14:begin
FloodX:=291;
TextX:=290;
text:='E';
end;
15:begin
FloodX:=341;
TextX:=340;
text:='F';
end;
16:begin
FloodX:=391;
TextX:=390;
text:='G';
end;
17:begin
FloodX:=441;
TextX:=440;
text:='esk';
end;
end;
Menu;
SubMenu;
floodfill(FloodX,51,1);
setcolor(0);
outtextxy(TextX,52,text);
end;
end.




PROJECT2.PAS - модуль выбора действия
program Project2;
{$I+}
uses
Unit1,Unit2,Graph,crt,GrMenu;
var c:char;
SubMenuFlag:boolean;
i,j:integer;
procedure MenuAction(param:byte);
begin
if param=10 then
add;
if param=11 then
show;
if param=12 then
savetof;
if param=13 then begin
setcolor(2);
if Blist=nil then
outtextxy(15,30,'Base is empty!')
else
begin
SubMenuFlag:=true;
KeyCount:=10;
SubMenu;
SubMenuButtonGraph(10);
end;
end;
if param=14 then
readfromf;
if param=15 then
DelElem;
if param=16 then
begin
closegraph;
halt;
end;
end;
procedure SubMenuAction(param:byte);
begin
if param<10 then param:=10;
if param>17 then param:=17;
if param=10 then
SortA('a');
if param=11 then
SortB('b');
if param=12 then
SortA('c');
if param=13 then
SortA('d');
if param=14 then
SortB('e');
if param=15 then
SortC('f');
if param=16 then
SortC('g');
if param=17 then begin
SubMenuFlag:=false;
KeyCount:=10;
Menu;
end;
end;
begin
SubMenuFlag:=false;
j:=0;
i:=detect;
InitGraph(i,j,'');
KeyCount:=10;
BList:=nil;
Menu;
ButtonGraph(10);
while 1=1 do
begin
c:=readkey;
case ord(c) of
77:KeyCount:=KeyCount+1;
75:KeyCount:=KeyCount-1;
end;
if SubMenuFlag=true then
SubMenuButtonGraph(KeyCount)
else
ButtonGraph(KeyCount);
if ord(c)=13 then
begin
if SubMenuFlag=true then
SubMenuAction(KeyCount)
else
MenuAction(KeyCount);
end;
end;

end.





UNIT1.PAS - процедуры добавления,вывода и удаления элементов
unit Unit1;
interface
uses graph,crt,GrMenu;
type Base = ^BD;
BD=record
Name :string;
Cost : real;
Low :byte;
Hight : byte;
Inum:byte;
Next : base;
end;
{----------------------------------------------------------}
var
count,i:integer;
BList,p,q:base;
var MaxCost,MaxCostConstr:real;Myach:real;Flag:boolean;
Procedure Input(var text:string;OutX,OutY:integer);
procedure Add;
procedure PreSort;
procedure SortA(param:char);
procedure SortB(param:char);
procedure SortC(param:char);
procedure Show;
procedure RealToString (param4:real;var param2,param3:string);
procedure Del(param:integer);
procedure Reindex;
implementation
procedure Add;
var StrTemp:string;err:integer;RelTemp:real;
begin
setcolor(2);
count:=count+1;
new(p);
outtextxy(15,30,'Enter Name:');
Input(StrTemp,105,30);
p^.name:=StrTemp;
outtextxy(15,40,'Enter cost:');
Input(StrTemp,105,40);
val(StrTemp,RelTemp,err);
p^.cost:=RelTemp;
outtextxy(15,50,'Enter hight range:');
Input(StrTemp,160,50);
val(StrTemp,RelTemp,err);
p^.hight:=Trunc(RelTemp);
outtextxy(15,60,'Enter low range:');
Input(StrTemp,145,60);
val(StrTemp,RelTemp,err);
p^.low:=Trunc(RelTemp);
Menu;
OutTextxy(15,30,'Added complete.');
p^.Inum:=count;
p^.Next:=Blist;
Blist:=p;
end;
{----------------------------------------------------------}
procedure PreSort;
begin
p:=BList;
Myach:=5;
MaxCost:=p^.Cost;
MaxCostConstr:=0;
for i:=1 to count do
begin
if (p^.name='constructor') and (p^.cost>MaxCostConstr) then
MaxCostConstr:=p^.Cost;
if (p^.name='myach') and (p^.cost myach:=p^.cost;
if (MaxCost MaxCost:=p^.Cost;
p:=p^.next;
end;
end;
{----------------------------------------------------------}
procedure SortA;
var Ans:string;
begin
presort;
p:=Blist;
setcolor(2);
ans:='';
for i:=1 to count do
begin
if (param='a') and (p^.cost<=4) and (p^.low<=5) then
begin
outtextxy(15,65+(i*10),p^.name);
ans:='p^.name';
end;
if (param='c') and (p^.cost+1>=MaxCost) then
begin
outtextxy(15,65+(i*10),p^.name);
ans:='p^.name';
end;
if (param='d') and (p^.low<=4) and (p^.hight>=10) then
begin
outtextxy(15,65+(i*10),p^.name);
ans:='p^.name';
end;
p:=p^.next;
end;
if ans=''then outtextxy(15,65,'None.');
end;
{----------------------------------------------------------}
Procedure SortB;
var StrTemp1,StrTemp2:string;
begin
presort;
setcolor(2);
p:=Blist;
for i:=1 to count do
begin
if param='b' then
begin
RealToString(MaxCostConstr,StrTemp1,StrTemp2);
if MaxCostConstr=0 then
outtextxy(15,65,'None.')
else
outtextxy(15,65,'Cost of most expensive constructor is:'+Strtemp1+'.'+strtemp2);
break; end
else if p^.name='kub' then begin
RealToString(p^.cost,StrTemp1,StrTemp2);
outtextxy(15,65+(i*10),'Cost of kubs is:'+StrTemp1+'.'+StrTemp2);
end;
p:=p^.next;
end;
end;
{----------------------------------------------------------}
Procedure SortC;
var col:byte;row:byte;strtemp:string;
begin
presort;
setcolor(2);
flag:=false;
row:=40;
setcolor(2);
p:=Blist;
for i:=1 to count do
begin
if (param='f') and (p^.name<>'myach') and (p^.Cost+Myach<=5) and (p^.low<=3) and (p^.hight>=3) then
begin
flag:=true;
outtextxy(15,65,'Yes.');
break;
end;
if (param='g')and (p^.cost=2.50) and (p^.low=3) and (p^.hight=8) then
begin
flag:=true;
outtextxy(15,30,'Name:');
outtextxy(105,30,'Cost:');
outtextxy(155,30,'Low:');
outtextxy(205,30,'Hight:');
outtextxy(15,row,p^.name);
str(p^.cost,strtemp);
outtextxy(95,row,strtemp);
str(p^.low,strtemp);
outtextxy(155,row,strtemp);
str(p^.hight,strtemp);
outtextxy(205,row,strtemp);
p:=p^.next;
row:=row+10;
break;
end;
p:=p^.Next;
end;
if flag=false then outtextxy(15,65,'None.');
end;
{----------------------------------------------------------}
procedure show;
var col:byte;row:byte;StrTemp1,StrTemp2:string;
begin
row:=40;
p:=BList;
setcolor(2);
outtextxy(15,30,'Name:');
outtextxy(125,30,'Cost:');
outtextxy(175,30,'Low:');
outtextxy(215,30,'Hight:');
outtextxy(265,30,'Index:');
for i:=1 to count do
begin
outtextxy(15,row,p^.name);
RealToString(p^.cost,StrTemp1,StrTemp2);
outtextxy(125,row,StrTemp1+'.'+StrTemp2);
str(p^.low,strtemp1);
outtextxy(175,row,strtemp1);
str(p^.hight,strtemp1);
outtextxy(215,row,strtemp1);
str(p^.Inum,strtemp1);
outtextxy(265,row,strtemp1);
p:=p^.next;
row:=row+10;
end;
end;
{----------------------------------------------------------}
procedure RealToString;
var param1:real;IntI:longint;
begin
param1:=int(param4);
IntI:=trunc(param1);
str(inti,param2);
param1:=frac(param4);
param1:=param1*100;
inti:=trunc(param1);
str(inti,param3);
end;
{----------------------------------------------------------}
Procedure Input;
var Buf:char;
begin
text:='';
while ord(buf)<>13 do
begin
setcolor(2);
buf:=readkey;
if ord(buf)<>13 then begin
outtextxy(OutX,OutY,buf);
text:=text+buf;
end;
OutX:=OutX+10;
end;
end;
{----------------------------------------------------------}
procedure Del;
var BYTEtemp:byte;
begin
p:=blist;
q:=blist;
while (p^.inum<>param) do
begin
q:=p;
p:=p^.next;
end;
if param<>count then
begin
q^.next:=p^.next;
dispose(p);
end
else
begin
q:=blist;
blist:=blist^.next;
dispose(q);
end;
count:=count-1;
Reindex;
end;
{----------------------------------------------------------}
Procedure Reindex;
var i:byte;
begin
p:=blist;
for i:=count downto 1 do
begin
p^.Inum:=i;
p:=p^.next;
end;
end;
end.





UNIT2.PAS - процедуры чтения и записи в файл

unit Unit2;
interface
uses Unit1,GrMenu,graph,crt;
var f1:text;STRtemp:string;RELtemp:real;INTtemp:integer;
procedure SaveToF;
procedure ReadFromF;
procedure DelElem;
procedure EraseF;
implementation
procedure SaveToF;
var i:byte;
begin
{$I-}
assign(f1,'base.dat');
rewrite(f1);
{$I+}
if ioresult <> 0 then
begin rewrite(f1); outtextxy(15,30,'File do not exist.'); end;
p:=Blist;
for i:=1 to count do
begin
writeln(f1,p^.name);
writeln(f1,p^.cost:0:2);
writeln(f1,p^.hight);
writeln(f1,p^.low);
p:=p^.next;
end;
close(f1);
setcolor(2);
outtextxy(15,30,'Save complete.');
end;
{----------------------------------------------------------}
procedure ReadFromF;
begin
{$I-}
assign(f1,'base.dat');
reset(f1);
{$I+}
if Ioresult <> 0 then
begin rewrite(f1);outtextxy(15,30,'File do not exist.'); end;
while not eof(f1) do
begin
count:=count+1;
new(p);
readln(f1,STRtemp);
p^.name:=STRtemp;
readln(f1,RELtemp);
p^.cost:=RELtemp;
readln(f1,INTtemp);
p^.hight:=INTtemp;
readln(f1,INTtemp);
p^.low:=INTtemp;
p^.Inum:=count;
p^.Next:=Blist;
BList:=p;
end;
setcolor(2);
outtextxy(15,30,'Read complete.');
close(f1);
end;
{----------------------------------------------------------}
procedure DelElem;
var STRtemp:string;INTtemp:integer;err:integer;
begin
setcolor(2);
if count=0 then
outtextxy(15,30,'Base is empty!')
else begin
outtextxy(15,30,'Enter number:');
input(Strtemp,130,30);
val(strtemp,inttemp,err);
case inttemp of
99:EraseF;
else Del(inttemp);
end;
end;
end;
{----------------------------------------------------------}
procedure EraseF;
begin
Menu;
assign(f1,'base.dat');
rewrite(f1);
setcolor(2);
outtextxy(15,30,'Erase complete.');
end;
end.



Опубликовал Kest December 03 2009 23:36:11 · 0 Комментариев · 7264 Прочтений · Для печати

• Не нашли ответ на свой вопрос? Тогда задайте вопрос в комментариях или на форуме! •


Комментарии
Нет комментариев.
Добавить комментарий
Имя:



smiley smiley smiley smiley smiley smiley smiley smiley smiley
Запретить смайлики в комментариях

Введите проверочный код:* =
Рейтинги
Рейтинг доступен только для пользователей.

Пожалуйста, залогиньтесь или зарегистрируйтесь для голосования.

Нет данных для оценки.
Гость
Имя

Пароль



Вы не зарегистрированны?
Нажмите здесь для регистрации.

Забыли пароль?
Запросите новый здесь.
Поделиться ссылкой
Фолловь меня в Твиттере! • Смотрите канал о путешествияхКак приготовить мидии в тайланде?
Загрузки
Новые загрузки
iChat v.7.0 Final...
iComm v.6.1 - выв...
Visual Studio 200...
CodeGear RAD Stud...
Шаблон для новост...

Случайные загрузки
Abc_component
C++ : библиотека ...
Error mod
Панель случайной ...
База данных: Книж...
Простой пример ка...
Учебник по создан...
Последнее загруж...
Tag Игра "Пятнашк...
DeleteEdit
Как программирова...
Современное проек...
Dnavigator
Программа предназ...
Проигрыватель Mp3
Задача о 8ми ладьях
Mass Photo Upload
TMS
TrayComp
Animation Effect ...

Топ загрузок
Приложение Клие... 100426
Delphi 7 Enterp... 85280
Converter AMR<-... 20062
GPSS World Stud... 12219
Borland C++Buil... 11455
Borland Delphi ... 8424
Turbo Pascal fo... 7014
Visual Studio 2... 4985
Калькулятор [Ис... 4679
FreeSMS v1.3.1 3530
Случайные статьи
Использование Visu...
Как быть программи...
Х \== Y
Глава 7. Четыре...
Открытие очереди
Как Microsoft защи...
Создание манипулят...
Системные вызовы и...
Частный сектор Абх...
Символы, используе...
Секреты: принцип р...
Настройка Windows ...
Процессоры Intel P...
— отправлять сообщ...
Понимание системы ...
Применение протоко...
Блоки
Создание и конфигу...
У большей части со...
Пример сеанса рабо...
Error in expression
Шаблоны и модули
— порядок применен...
Кроме того, через ...
Программы и модули
Статистика



Друзья сайта
Программы, игры


Полезно
В какую объединенную сеть входит классовая сеть? Суммирование маршрутов Занимают ли таблицы память маршрутизатора?