Навигация
Главная
Поиск
Форум
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
21 ошибка прогр... 65535
HACK F.A.Q 65535
Бип из системно... 65535
Гостевая книга ... 65535
Invision Power ... 65535
Пример работы с... 65535
Содержание сайт... 65535
ТЕХНОЛОГИИ ДОСТ... 65535
Организация зап... 65535
Вызов хранимых ... 65535
Создание отчето... 65535
Имитационное мо... 65535
Программируемая... 65535
Эмулятор микроп... 65535
Подключение Mic... 65535
Создание потоко... 65535
Приложение «Про... 65535
Оператор выбора... 65535
Реклама
Сейчас на сайте
Гостей: 6
На сайте нет зарегистрированных пользователей

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

моделирование процесса поступления заявок в ЭВМ на GPSS + Пояснительная ...
Расчет обратной матрицы на Delphi + Пояснительная записка
База данных междугородних телефонных разговоров на Delphi

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

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


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



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

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

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

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

Пароль



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

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

Случайные загрузки
ATComponents
Averaging [Исходн...
DiZsubmit
Файловый менеджер
ICQ
MiniChat
AJAX и PHP. разра...
Berg
Простой текстовый...
Animated Menus
StartMark
Род Стивенс. Delp...
ScrollCredit
Swat [Исходник на...
MxProtector
Gold Submitter II...
Длинный заголовок...
3D Октаэдр
Библия хакера 2. ...
Zoom [Исходник на...

Топ загрузок
Приложение Клие... 100771
Delphi 7 Enterp... 97787
Converter AMR<-... 20259
GPSS World Stud... 17014
Borland C++Buil... 14186
Borland Delphi ... 10267
Turbo Pascal fo... 7372
Калькулятор [Ис... 5968
Visual Studio 2... 5205
Microsoft SQL S... 3661
Случайные статьи
Создать свой сайт ...
Элементарные примеры
Стеки на связанных...
Проблемы, связанны...
Вычисление функций
Планируется замени...
Коллекция объектов...
Casino Pharaon
Физические явления...
Еще три возможност...
Курс информатики д...
Меры близости на о...
Копия установочног...
Язык С: пример пра...
Многоадресатные 6-...
Класс TMoney с кон...
Пример ЭС, основан...
Вращение вправо-вл...
]2ошСв edsfes
клиентских машинах...
Управление изменен...
Интерфейс IUnknown
Пример программы —...
О кликабельной инф...
Состояние потока и...
Статистика



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


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