Навигация
Главная
Поиск
Форум
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
Программируемая... 65535
Эмулятор микроп... 65535
Подключение Mic... 65535
Приложение «Про... 65535
Оператор выбора... 65535
Invision Power ... 65259
Организация зап... 63908
Модуль Forms 60830
Создание отчето... 60690
ТЕХНОЛОГИИ ДОСТ... 57011
Создание потоко... 56334
Пример работы с... 54231
Имитационное мо... 52463
Реклама
Сейчас на сайте
Гостей: 8
На сайте нет зарегистрированных пользователей

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

Моделирование интернет кафе на GPSS + Отчет
Моделирование работы перекрёстка по регулированию движения на GPSS + Поя...
База данных электронного документооборота на Delphi + бд Intebase

Реклама



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

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


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



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

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

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

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

Пароль



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

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

Случайные загрузки
PHP 5
Проигрыватель Mp3
Flud Vkontakte.ru
Удаление своего EXE
Язык программиров...
Программирование ...
Пример работы с б...
Фундаментальные а...
База данных: Книж...
Электронный магаз...
Развивающийся фла...
Клавиатурный трен...
DAlarm
Язык программиров...
Converter AMR<->W...
Cтатьи Королевств...
DFileDeleter
База для Allsubmi...
Панель статистики...
Пользовательская...

Топ загрузок
Приложение Клие... 100376
Delphi 7 Enterp... 83060
Converter AMR<-... 20046
Borland C++Buil... 11173
GPSS World Stud... 10883
Borland Delphi ... 8120
Turbo Pascal fo... 6973
Visual Studio 2... 4963
Калькулятор [Ис... 4354
FreeSMS v1.3.1 3510
Случайные статьи
Какая команда выво...
Логическая задача ...
чтения смарт-карт,...
2. С помощью IEAK ...
10 основных способ...
Как выключить/пере...
ПРИЛОЖЕНИЕ С. РАЗ...
РезюмеМы рассмотре...
и режим ядра гаран...
Вычисление значени...
Классы ORM.
Параллелизм и комп...
Учитесь у плотников
Листинг 14.4. Доба...
Наследование
Добавление узлов к...
ws — объект
Варианты заданий
Немного о прерываниях
Назначение и особе...
Поместите все подд...
Информационный обм...
Описание типа доку...
Функции для выполн...
Старший и младший ...
Статистика



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


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