Навигация
Главная
Поиск
Форум
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
Вызов хранимых ... 65535
Эмулятор микроп... 65535
Бип из системно... 60691
Invision Power ... 58593
Организация зап... 58566
Модуль Forms 57057
Приложение «Про... 56808
Оператор выбора... 56240
Создание отчето... 55993
Подключение Mic... 55851
ТЕХНОЛОГИИ ДОСТ... 52192
Программируемая... 49485
Пример работы с... 48011
Имитационное мо... 47741
21 ошибка прогр... 42703
Реклама
Сейчас на сайте
Гостей: 13
На сайте нет зарегистрированных пользователей

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

Моделирование системы управления качеством производственного процесса на...
Компьютерный магазин на Turbo Pascal (База данных) + Пояснительная записка
Моделирование работы обрабатывающего участка цеха в GPSS

Реклама

База данных на паскале 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 Комментариев · 6708 Прочтений · Для печати

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


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



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

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

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

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

Пароль



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

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

Случайные загрузки
БД студентов
Алгоритм трассиро...
C++ для начинающих
PHP глазами хакера
Delphi 6/7 базы д...
EditNew
Пишем программы и...
Animation Effect ...
SendSMS для PHP-F...
Советы по Delphi
Усложнённый кальк...
Заставка. Изображ...
Отключение и вклю...
Пример создания W...
Srinilist
Модифицированная ...
Карта сайта
Длинный заголовок...
Indy in Depth Глу...
Х. М. Дейтел, П. ...

Топ загрузок
Приложение Клие... 100307
Delphi 7 Enterp... 77869
Converter AMR<-... 20021
Borland C++Buil... 10672
GPSS World Stud... 9246
Borland Delphi ... 7658
Turbo Pascal fo... 6884
Visual Studio 2... 4906
Калькулятор [Ис... 3993
FreeSMS v1.3.1 3486
Случайные статьи
Работа со списками...
Ошибки при передач...
Применение открыто...
16 правил оптимиза...
Синтаксис регулярн...
Группа блоков созд...
Членам групп не да...
Современные телеко...
Оптимизация под MSN
Назначение класса ...
Управление свойств...
Простая ассоциация
Секреты: принцип р...
Вывести все ссылки...
Инициализация глоб...
9.6. Дополнительна...
Настройка параметр...
Продвижение сайтов...
Шаблоны
Площадка с тенью ...
Функции ввода симв...
Интернет-ресурсы, ...
Свойству AutoPostBack
Сборочные машины
Также необходимо з...
Статистика



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


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