-Музыка

 -Подписка по e-mail

 

 -Поиск по дневнику

Поиск сообщений в xpackpackax

 -Статистика

Статистика LiveInternet.ru: показано количество хитов и посетителей
Создан: 09.01.2009
Записей:
Комментариев:
Написано: 1835





Задание псевдонима программным путем

Вторник, 06 Октября 2009 г. 22:24 + в цитатник
Эта информация поможет вам разобраться в вопросе создания и использования ПСЕВДОНИМОВ баз данных в ваших приложениях.

Вне Delphi создание и конфигурирование псевдонимов осуществляется утилитой BDECFG.EXE. Тем не менее, применяя компонент TDatabase, вы можете в вашем приложении создать и использовать псевдоним, не определенный в IDAPI.CFG.

Важно понять, что создав псевдоним, использовать его можно только в текущем сеансе вашего приложения. Псевдонимы определяеют расположение таблиц базы данных и параметры связи с сервером баз данных. В конце концов, вы получаете преимущества использования псевдонимов в пределах вашего приложения без необходимости беспокоиться о наличии их в конфигурационном файле IDAPI.CFG в момент инициализации приложения.

Некоторые варианты решения задачи:

Пример #1:

Пример #1 создает и конфигурирует псевдоним для базы данных STANDARD (.DB, .DBF). Псевдоним затем используется компонентом TTable.

Пример #2:

Пример #2 создает и конфигурирует псевдоним для базы данных INTERBASE (.gdb). Псевдоним затем используется компонентом TQuery для подключения к двум таблицам базы данных.

Пример #3:

Пример #3 создает и конфигурирует псевдоним для базы данных STANDARD (.DB, .DBF). Демонстрация ввода псевдонима пользователем и его конфигурация во время выполнения программы.

Пример #1: Используем базу данных .DB или .DBF (STANDARD)
Создаем новый проект.
Располагаем на форме следующие компоненты: - TDatabase, TTable, TDataSource, TDBGrid, and TButton.
Дважды щелкаем на компоненте TDatabase или через контекстное меню (правая кнопка мыши) вызываем редактор базы данных.
Присваиваем базе данных имя 'MyNewAlias'. Это имя будет выполнять роль псевдонима в свойстве DatabaseName для компонентов типа TTable, TQuery, TStoredProc.
Выбираем в поле Driver Name (имя драйвера) пункт STANDARD.
Щелкаем на кнопке Defaults. Это автоматически добавляет путь (PATH=) в секцию перекрытых параметров (окно Parameter Overrides).
Устанавливаем PATH= to C:\DELPHI\DEMOS\DATA (PATH=C:\DELPHI\DEMOS\DATA).
Нажимаем кнопку OK и закрываем окно редактора.
В компоненте TTable свойству DatabaseName присваиваем 'MyNewAlias'.
В компоненте TDataSource свойству DataSet присваиваем 'Table1'.
В компоненте DBGrid свойству DataSource присваиваем 'DataSource1'.
Создаем в компоненте TButton обработчик события OnClick.
procedure TForm1.Button1Click(Sender: TObject);
begin
Table1.Tablename:= 'CUSTOMER';
Table1.Active:= True;
end;


Запускаем приложение.

*** В качестве альтернативы шагам 3 - 11, вы можете включить все эти действия в сам обработчик:
procedure TForm1.Button1Click(Sender: TObject);
begin
Database1.DatabaseName:= 'MyNewAlias';
Database1.DriverName:= 'STANDARD';
Database1.Params.Clear;
Database1.Params.Add('PATH=C:\DELPHI\DEMOS\DATA');
Table1.DatabaseName:= 'MyNewAlias';
Table1.TableName:= 'CUSTOMER';
Table1.Active:= True;
DataSource1.DataSet:= Table1;
DBGrid1.DataSource:= DataSource1;
end;



Пример #2: Используем базу данных INTERBASE
Создаем новый проект.
Располагаем на форме следующие компоненты: - TDatabase, TQuery, TDataSource, TDBGrid, and TButton.
Дважды щелкаем на компоненте TDatabase или через контекстное меню (правая кнопка мыши) вызываем редактор базы данных.
Присваиваем базе данных имя 'MyNewAlias'. Это имя будет выполнять роль псевдонима в свойстве DatabaseName для компонентов типа TTable, TQuery, TStoredProc.
Выбираем в поле Driver Name (имя драйвера) пункт INTRBASE.
Щелкаем на кнопке Defaults. Это автоматически добавляет путь (PATH=) в секцию перекрытых параметров (окно Parameter Overrides).
SERVER NAME=IB_SERVEER:/PATH/DATABASE.GDB
USER NAME=MYNAME
OPEN MODE=READ/WRITE
SCHEMA CACHE SIZE=8
LANGDRIVER=
SQLQRYMODE=
SQLPASSTHRU MODE=NOT SHARED
SCHEMA CACHE TIME=-1
PASSWORD=
Устанавливаем следующие параметры
SERVER NAME=C:\IBLOCAL\EXAMPLES\EMPLOYEE.GDB
USER NAME=SYSDBA
OPEN MODE=READ/WRITE
SCHEMA CACHE SIZE=8
LANGDRIVER=
SQLQRYMODE=
SQLPASSTHRU MODE=NOT SHARED
SCHEMA CACHE TIME=-1
PASSWORD=masterkey
В компоненте TDatabase свойство LoginPrompt устанавливаем в 'False'. Если в секции перекрытых параметров (Parameter Overrides) задан пароль (ключ PASSWORD) и свойство LoginPrompt установлено в 'False', при соединении с базой данный пароль запрашиваться не будет. Предупреждение: при неправильно указанном пароле в секции Parameter Overrides и неактивном свойстве LoginPrompt вы не сможете получить доступ к базе данных, поскольку нет возможности ввести правильный пароль - диалоговое окно "Ввод пароля" отключено свойством LoginPrompt.
Нажимаем кнопку OK и закрываем окно редактора.
В компоненте TQuery свойству DatabaseName присваиваем 'MyNewAlias'.
В компоненте TDataSource свойству DataSet присваиваем 'Query1'.
В компоненте DBGrid свойству DataSource присваиваем 'DataSource1'.
Создаем в компоненте TButton обработчик события OnClick.
procedure TForm1.Button1Click(Sender: TObject);
begin
Query1.SQL.Clear;
Query1.SQL.ADD(
'SELECT DISTINCT * FROM CUSTOMER C, SALES S
WHERE (S.CUST_NO = C.CUST_NO)
ORDER BY C.CUST_NO, C.CUSTOMER');
Query1.Active:= True;
end;


Запускаем приложение.

Пример #3: Ввод псевдонима пользователем

Этот пример выводит диалоговое окно и создает псевдоним на основе информации, введенной пользователем.

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

Выполняем шаги 1-11 из примера #1.
Пишем следующий обработчик события OnClick компонента TButton:
procedure TForm1.Button1Click(Sender: TObject);
var
NewString: string;
ClickedOK: Boolean;
begin
NewString := 'C:';
ClickedOK := InputQuery('Database Path',
'Path: --> C:\DELPHI\DEMOS\DATA', NewString);
if ClickedOK then
begin
Database1.DatabaseName := 'MyNewAlias';
Database1.DriverName := 'STANDARD';
Database1.Params.Clear;
Database1.Params.Add('Path=' + NewString);
Table1.DatabaseName := 'MyNewAlias';
Table1.TableName := 'CUSTOMER';
Table1.Active := True;
DataSource1.DataSet := Table1;
DBGrid1.DataSource := DataSource1;
end;
end;

Как открыть базу данных Microsoft Access .MDB в Delphi

Вторник, 06 Октября 2009 г. 22:21 + в цитатник
ADO

Если у Вас Delphi 5 Enterprise или Delphi 5 Professional с ADO Express, то Вы можете использовать компонент ADOTable и в его свойстве ConnectionString настроить (build) подключение как базе данных MS Access. Например:

Provider=Microsoft.Jet.OLEDB.4.0;
User ID=Admin;
Password=Password;
Data Source=D:\Path\dbname.mdb;
Mode=ReadWrite;
Extended Properties=" " ;
Persist Security Info=False;
Jet OLEDB:System database=" " ;
Jet OLEDB:Registry Path=" " ;
Jet OLEDB:Database Password=" " ;
Jet OLEDB:Engine Type=5;
Jet OLEDB:Database Locking Mode=1;
Jet OLEDB:Global Partial Bulk Ops=2;
Jet OLEDB:Global Bulk Transactions=1;
Jet OLEDB:New Database Password=" " ;
Jet OLEDB:Create System Database=False;
Jet OLEDB:Encrypt Database=False;
Jet OLEDB:Don't Copy Locale on Compact=False;
Jet OLEDB:Compact Without Replica Repair=True;
Jet OLEDB:SFP=False

При этом будет открыта база данных D:\Path\dbname.mdb, будет использован драйвер ADO для базы данных Access (Microsoft.Jet.OLEDB.4.0). Имя пользователя будет Admin без пароля (эти значения присваиваются поумолчанию при создании базы Access). Если Вы всё-таки захотите использовать пароль, то его надо будет задать в ствойстве Jet OLEDB:Database Password. Если у Вас установлен режим безопасности, то необходимо указать файл .MDW или .MDA в свойстве Jet OLEDB:System database.

BDE

Так же для открытия базы данных Access можно воспользоваться BDE которая содержит родной драйвер (MSACCESS). В компоненте Database установите следующие свойства:

DatabaseName = any_name (или alias_name)
DriverName = MSACCESS
LoginPrompt = False
Params = PATH=d:\path
DATABASE NAME=d:\path\filename.mdb
TRACE MODE=0
LANGDRIVER=Access General
USER NAME=Admin
PASSWORD=your_password
OPEN/MODE=READ/WRITE
SQLPASSTHRU MODE=NOT SHARED

Значения свойства DatabaseName объекта Database, это то, которое Вы будете использовать в свойстве DatabaseName компонентов Table и Query, которые представляют таблицы и запросы для этой базы данных (тем самым связывая их с объектом Database).

BDE+ODBC

В случае с базой данных Access, BDE предоставляет драйвер, однако существует множество других баз, для которых в BDE драйвера нет, но для которых есть драйвер ODBC. ODBC обычно используется для небольших баз данных или в приложениях, в которых присутствуют только операции импорта/экспорта...

Ниже приведён пример использования драйвера ODBC с BDE для открытия базы данных Access:

Создайте DSN (Data Source Name) для Вашей базы данных (используя апплет ODBC Data Sources в панели управления).
Кликните на закладку " System DSN" или " User DSN"
Кликните по кнопке " Add..."
Выберите " Microsoft Access Driver (*.mdb)" и нажмите ENTER. Появится диалоговое окошко " ODBC Microsoft Access Setup" .
Задайте имя в текстовом окошке Data Source Name (без пробелов и без специальных символов).
Кликните по кнопке " Select..." чтобы выбрать нужный файл .MDB.
Если у Вас установлена схема безопасноти, то выберите радио кнопку " Database" в " System Database" , а затем кликните кнопку " System database..." , чтобы указать файл рабочей группы .MDW или .MDA.
Если Вы хотите указать имя пользователя и пароль, то нажмите кнопку " Advanced..." . Данный способ защиты является низкоуровневым, так как любой, кто имеет доступ к Вашей машине может спокойно посмотреть свойства DSN. Если Вам необходим более высокий уровень защиты, то задавать имя пользователя и пароль необходимо на стадии открытия базы данных (см. ниже).
В заключении нажмите " OK" , после чего Ваш DSN будет сохранён.
В Delphi установите свойства компонента TDatabase:
В DatabaseName задайте имя, которое указали в DSN.
Если Вы хотите, чтобы пользователя спрашивали имя и пароль, то установите LoginPrompt в True.
Если Вы не хотите использовать стандартный диалог имени и пароля (или если имя и пароль будут задаваться программно), то установите LoginPrompt в False и задайте свойство Params (или задайте эти свойства по ходу выполнения программы):
USER NAME=your_username
PASSWORD=your_password
Свяжите компоненты TTable или TQuery с компонентом TDatabase, как рассказывалось Выше, просто указав тоже имя (которое было задано в DSN) в их соответствующих свойствах DatabaseName.

Как можно открыть отчёт (в режиме Print Preview а также Print Direct) в MS Access

Вторник, 06 Октября 2009 г. 22:18 + в цитатник
var
Access: Variant;
begin
// Открываем Access
try
Access := GetActiveOleObject('Access.Application');
except
Access := CreateOleObject('Access.Application');
end;
Access.Visible := True;

// Открываем базу данных
// Второй параметр указывает - будет ли база открыта в Exclusive режиме
Access.OpenCurrentDatabase('C:\My Documents\Books.mdb', True);

// открываем отч¸т
{Значение второго пораметра может быть одним из следующих
acViewDesign, acViewNormal, or acViewPreview. acViewNormal,
которые устанавливаются по умолчанию, для печати отч¸та.
Если Вы не используете библиотеку типов, то можете определить
эти значения следующими:

const
acViewNormal = $00000000;
acViewDesign = $00000001;
acViewPreview = $00000002;

Третий параметр - это имя очереди для текущей базы данных.
Четв¸ртый параметр - это строка для SQL-евского WHERE -
то есть строка SQL, минус WHERE.}

Access.DoCmd.OpenReport('Titles by Author', acViewPreview, EmptyParam,
EmptyParam);

< ... >

// Закрываем базу данных
Access.CloseCurrentDatabase;

// Закрываем Access
{const
acQuitPrompt = $00000000;
acQuitSaveAll = $00000001;
acQuitSaveNone = $00000002;}
Access.Quit(acQuitSaveAll);
end;

Использование таблиц Access2

Вторник, 06 Октября 2009 г. 22:16 + в цитатник
Можно ли как-то в Delphi работать с файлами Microsoft Access? Я слышал что некоторые программисты пробовали, но у них ничего не получилось.

Из приложений Delphi вы можете получить доступ к .MDB-файлам Microsoft Access, используя драйверы ODBC. Delphi действительно может дать все необходимое, но некоторые вещи не столь очевидные. Вот шаги для достижения вашей цели.

Что вам нужно: Первое: проверьте, установлен ли ODBC Administrator (файл ODBCADM.EXE в WINDOWS\SYSTEM, вам также необходим файл DBCINST.DLL для установки новых драйверов и ODBC.DLL). Администратор ODBC должен присутствовать в Панели Управления в виде иконки ODBC. Если у вас его не было, то после установки Delphi он должен появиться. Если вы получаете сообщение типа "Your ODBC is not up-to-date IDAPI needs ODBC greater then 2.0", у вас имеется старая версия администратора и вы должны обновить ее до версии, включенной в поставку Delphi. Проверьте, имеете ли вы доступ к драйверу Access ODBC, установленному в Windows. Вы можете сделать это, щелкнув на "Drivers" в диалоговом окне "Data Sources", появляющемся при запуске ODBC Administrator. Delphi должна в диалоге добавить пункты Access Files (*.mdb) и Access Data (*.mdb), работающие с файлами Access 1.10 и использующие драйвер SIMBA.DLL (имейте в виду, что для данного DLL необходимы также файлы RED110.DLL и SIMADMIN.DLL, устанавливаемые для вас Delphi). Данные файлы должны поставляться с дистрибутивом вашей программы как часть ReportSmith Runtime библиотеки. Если вы хотите работать с файлами Access 2.0 или 2.5, вам необходимо иметь другой набор драйверов от Microsoft. Ключевой файл - MSAJT200.DLL, также необходимы файлы MSJETERR.DLL и MSJETINT.DLL. В США набор ODBC Desktop Drivers, Version 2.0. стоит $10.25. Он также доступен в январском выпуске MSDN, Level 2 (Development Platform) CD4 \ODBC\X86 как часть ODBC 2.1 SDK. Очевидно есть обновление этих драйверов для файлов Access 2.5 на форуме MSACCESS CompuServe. Имейте в виду, что драйвер Access ODBC, поставляемый с некоторыми приложениями Microsoft (например, MS Office) могут использоваться только другими MS-приложениями. К сожалению, они могут сыграть с вами злую шутку: сначала заработать, а потом отказать в совершенно неподходящий момент! Поэтому не обращайте внимания (запретите себе обращать внимание!) на строчку "Access 2.0 for MS Office (*.mdb)" в списке драйверов ODBC Administrator. Вы можете установить новые ODBC драйверы с помощью ODBC Administrator в Панели Управления.

Добавление источника данных ODBC (Data Source): если у вас имеются все необходимые файлы, можете начинать. Представленный здесь пример использует драйвер Access 1.10, обеспечиваемый Delphi. Используя ODBC Administrator, установите источник данных для ваших файлов Access: щелчок на кнопке "Add" в окне "data sources" выведет диалог "Add Data Source", выберите Access Files (*.mdb) (или что-либо подходящее, в зависимости от установленных драйверов). В диалоге "ODBC Microsoft Access Setup" необходимо ввести имя в поле "Data Source Name". В данном примере мы используем "My Test". Введите описание "Data Source" в поле Description. Щелкните на "Select Database" для открытия диалога "Select Database". Перейдите в директорию, где хранятся ваши Access .MDB-файлы и выберите один. Мы выберем файл TEST.MDB в директории C:\DELPROJ\ACCESS. Нажмите OK в диалоге "Setup". Теперь в списке источников данных (Data Sources) должен появиться "My Test" (Access Files *.mdb). Нажмите Close для выхода из ODBC Administrator. Используя этот метод, вы можете установить и другие, необходимые вам, источники данных.

Настройка Borland Database Engine: загрузите теперь Borland Database Engine (BDE) Configuration Utility. На странице "Drivers" щелкните на кнопке New ODBC Driver. Имейте в виду, что это добавит драйвер Access в BDE и полностью отдельное управление дополнительно к драйверам Access в Windows, устанавливаемым при помощи ODBC Administrator. В открывшемся диалоге Add ODBC Driver в верхнем поле редактировании введите ACCESS (или что-то типа этого). BDE автоматически добавит на первое место ODBC_. В combobox, расположенном немного ниже, выберите Access Files (*.mdb). Выберите Data Source в следующем combobox (Default Data Source Name), это должен быть источник данных, который вы установили с помощью ODBC Administration Utility. Здесь можно не беспокоиться о вашем выборе, поскольку позднее это можно изменить (позже вы узнаете как это можно сделать). Нажмите OK. После установки драйвера BDE, вы можете использовать его более чем с одним источником данных ODBC, применяя различные псевдонимы (Alias) для каждого ODBC Data Source. Для установки псевдонима переключитесь на страницу "Aliases" и нажмите на кнопку "New Alias". В диалоговом окне "Add New Alias" введите необходимое имя псевдонима в поле "Alias Name". В нашем примере мы используем MY_TEST (не забывайте, что пробелы в псевдониме недопустимы). В combobox Alias Type выберите имя ODBC-драйвера, который вы только что создали (в нашем случае ODBC_ACCESS). Нажмите OK. Если вы имеете более одного ODBC Data Source, измените параметр ODBC DSN ("DSN" = "Data Source Name") в списке "Parameters" псевдонима на подходящий источник данных ODBC Data Source, как установлено в ODBC Administrator. Имейте в виду, что вы не должны ничего добавлять в параметр Path (путь), так как ODBC Data Source уже имеет эту информацию. Если вы добавляете параметр Path, убедитесь, что путь правильный, в противном случае ничего работать не будет! Теперь сохраните конфигурацию BDE, выбирая пункты меню File|Save, и выходите из Database Engine Configuration Utility.

В Delphi: Создайте новый проект и расположите на форме компоненты Table и DataSource из вкладки Data Access палитры компонентов. Затем из вкладки Data Controls выберите компонент DBGrid и также расположите его на форме. В Table, в Инспекторе Объектов, назначьте свойству DatabaseName псевдоним MY_TEST, установленный нами в BDE Configuration Utility. Теперь спуститесь ниже и раскройте список TableName. Вас попросят зарегистрироваться в базе данных Access MY_TEST. Обратите внимание, что если бюджет не установлен, то User Name и Password можно не заполнять, просто нажмите на кнопку OK. После некоторой паузы раскроется список, содержащий доступные таблицы для ODBC Data Source указанного псевдонима BDE. Выберите TEST. В DataSource, в Инспекторе Объектов, назначьте свойству DataSet таблицу Table1. В DBGrid, также в Инспекторе Объектов, назначьте свойству DataSource значение DataSource1. Возвратитесь к таблице, и в том же Инспекторе Объектов установите свойство Active в True. Данные из таблицы TEST отобразятся в табличной сетке. Это все! Одну вещь все-таки стоит упомянуть: если вы создаете приложение, использующее таблицы Access и запускаете его из-под Delphi IDE, то при попытке изменения данных в таблице(ах) вы получите ошибку. Если же вы запустите скомпилированный .EXE-файл вне Delphi (предварительно Delphi закрыв), то все будет ОК. Сообщения об ошибках ODBC, к несчастью, очень туманные и бывает достаточно трудно понять его источник в вашем приложении, в этом случае проверьте установку ODBC Administrator и BDE Configuration Utility, они также могут помочь понять источник ошибки. Для получения дополнительной информации обратитесь к ODBC 2.0 Programmer's Reference или SDK Guide от Microsoft Press (ISBN 1-55615-658-8, цена в США составляет $24.95). В этом документе вы получите исчерпывающую информацию о возможных ошибках при использовании Access-файлов посредством ODBC. Также здесь вы можете найти рапорты пользователей о найденных ошибках, в том числе и при использовании Delphi. Более того, я выяснил, что большинство описанных проблем возникает при неправильных настройках ODBC, т.е. те шаги, которые я описал выше. Надеюсь, что с развитием технологии доступа к базам данных такие сложности уйдут в прошлое. Кроме того, имейте в виду, что если вам необходимо создать новую таблицу Access 1.10, вы можете воспользоваться Database Desktop, включаемый в поставку Delphi.

Авторы данной технологии Ralph Friedman (CompuServe 100064,3102), Bob Swart и Chris Frizelle.

Использование таблиц Access

Вторник, 06 Октября 2009 г. 22:15 + в цитатник
Может кто-нибудь, предпочтительно из персонала Borland, ПОЖАЛУЙСТА, дать мне ПОЛНЫЙ рассказ о том, как с помощью Delphi и сопутствующего программного обеспечения получить доступ и работать с базами данных MS Access. Среди прочего, мне необходимо узнать...

Нижеследующая инструкция в точности повторяет ту технологию, с которой я работаю на данный момент, надеюсь, что это поможет.

Драйвер ODBC, предусмотренный для доступа к Access 2.0, разработан только для работы в пределах среды Microsoft Office. Для работы со связкой ODBC/Access в Delphi, вам необходим Microsoft ODBC Desktop Driver kit, part# 273-054-030, доступный через Microsoft Direct за $10.25US (если вы живете не в США, воспользуйтесь службой WINEXT). Он также доступен в январском выпуске MSDN, Level 2 (Development Platform) CD4 \ODBC\X86 как часть ODBC 2.1 SDK. Имейте в виду, что смена драйверов (в частности Desktop Drivers) может негативно сказаться на работе других приложений Microsoft. Для информации (и замечаний) обращайтесь в форум WINEXT.

Также вам необходимы следующие файлы ODBC:

Минимум:
ODBC.DLL 03.10.1994, Версия 2.00.1510
ODBCINST.DLL 03.10.1994, Версия 2.00.1510
ODBCINST.HLP 11.08.1993
ODBCADM.EXE 11.08.1993, Версия 1.02.3129

Рекомендуется:
ODBC.DLL 12.07.1994, Версия 2.10.2401
ODBCINST.DLL 12.07.1994, Версия 2.10.2401
ODBCINST.HLP 12.07.1994
ODBCADM.EXE 12.07.1994, Версия 2.10.2309

Нижеследующие шаги приведут вас к искомой цели:

Используя администратора ODBC, установите источник данных (datasource) для вашей базы данных. Не забудьте задать путь к вашему mdb-файлу. Для нашего примера создайте источник с именем MYDSN.
Загрузите утилиту BDE Configuration.
Выберите пункт "New Driver".
Назначьте драйверу имя (в нашем случае ODBC_MYDSN).
В выпадающем списке драйверов выберите "Microsoft Access Driver (*.mdb)
В выпадающем списке имен выберите MYDSN
Перейдите на страницу "Alias" (псевдонимы).
Выберите "New Alias" (новый псевдоним).
Введите MYDSN в поле имени.
Для Alias Type (тип псевдонима) выберите ODBC_MYDSN.
На форме Delphi разместите компоненты DataSource, Table, и DBGrid.
Установите DBGrid1.DataSource на DataSource1.
Установите DataSource1.DataSet на Table1.
Установите Table1.DatabaseName на MYDSN.
В свойстве TableName компонента Table1 щелкните на стрелочку "вниз" и вы увидите диалог "Login". Нажмите OK и после короткой паузы вы увидите список всех имен ваших таблиц. Выберите одно.
Установите свойство Active Table1 в True и данные вашей таблицы появятся в табличной сетке.

Быстрая обработка CSV файла

Вторник, 06 Октября 2009 г. 22:13 + в цитатник
Классы Tstrings/TStringlist имеют свойство commatext, которое автоматически разделяет строки, содержащие разделители, на отдельные части. Пример показывает как считать CSV файл. В Конечном итоге, автоматически разделённые строки содержатся в TStringlist.
var
ts: tstringlist;
S: string;
Tf: Textfile;
begin
Ts := Tstringlist.create;
Assignfile(tf, 'filename');
Reset(tf);
while not eof(tf) do
begin
Readln(tf,S);
Ts.CommaText := S;
//ProcessLine;
end;
closefile(tf);
ts.free;
end;



Так же операцию можно производить в обратном порядке.

Свойство Commatext поддерживает разделители как в виде запятых, так и двойных кавычек: 1,2,3,4 и "1","2","3","4"

Например, строка вида "1","2,3","4" будет разделена на три элемента, которые заключены в кавычки (средняя запятая будет проигнорирована). Чтобы включить кавычку в конечный результ, нужно поставить две кавычки подряд: "1",""2" (результат будет 1 и "2 ).

RecCount в таблицах ASCII

Вторник, 06 Октября 2009 г. 22:11 + в цитатник
В Delphi 1.0 для получения количества записей в ASCII файле (.TXT- и .SCH-файлы) я пользовался свойством RecordCount компонента TTable. В Delphi 2.0 эта функциональность не поддерживается! Я прав или не прав? Во всяком случае как мне получить количество записей, содержащихся в ASCII таблице?

В Delphi 2.0, свойство RecordCount отображается на недокументированную функцию BDE DbiGetExactRecordCount. Данное изменение было сделано для обеспечения правильных величин при работе с "живыми" запросами. Очевидно, данное API по какой-то причине не поддерживает текстовые файлы.

Вы можете обойти эту проблему, вызывая функцию API BDE DbiGetRecordCount напрямую (добавьте BDE к списку используемых модулей):
procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word;
var
RecCount: Integer;
begin
Check(DbiGetRecordCount(Table1.Handle, RecCount);
end;

ASCII-файл с использованием полей

Вторник, 06 Октября 2009 г. 22:11 + в цитатник
В том случае, когда вы собираетесь использовать содержимое текстового файла таким образом, как будто он имеет поля, вам необходим файл схемы, содержащий описание формата текстового файла и который необходим для осуществления вызовов при работе с полями (Fields / FieldByName / Post / и др.). Ниже приводится код, который вы можете использовать при создании своей программы:
{ Подразумеваем, что Table1 - файл, который мы хотим скопировать
в ASCII-файл. Используем TBatchMove, поскольку быстро работает.
Также это автоматически создаст файл схемы }

procedure TForm1.Button1Click(Sender: TObject);
var

oDest: TTable;
oBMove: TBatchMove;
begin

try
oDest := nil;
oBMove := nil;
Table1.Close;

oDest := TTable.Create(nil);
with oDest do
begin
DatabaseName := 'c:\delphi\files';
TableName := 'Test.Txt';
TableType := ttASCII;
end; {Обратите внимание на то, что нет необходимости вызывать CreateTable}

oBMove := TBatchMove.Create(nil);
with oBMove do
begin
Source := Table1;
Destination := oDest;
Mode := batCopy;
Execute;
end;
finally
if Assigned(oDest) then
oDest.Free;
if Assigned(oBMove) then
oBMove.Free;
end;
end;

{ Теперь, допустим, файл схемы существует;
сам текстовый файл может как быть, так его может и не быть.
С помощью файла схемы мы уже можем работать с полями }

procedure TForm1.Button2Click(Sender: TObject);
var

oTxt: TTable;
i: Integer;
f: System.Text;
begin

try
oTxt := nil;

if not FileExists('c:\delphi\files\Test.Txt') then
begin
AssignFile(f, 'c:\delphi\files\Test.Txt');
Rewrite(f);
CloseFile(f);
end;

oTxt := TTable.Create(nil);
with oTxt do
begin
DatabaseName := 'c:\delphi\files';
TableName := 'Test.Txt';
TableType := ttASCII;
Open;
end;

with Table1 do
begin
DisableControls;
if not Active then
Open;
First;
while not EOF do
begin
oTxt.Insert;
{ В данном случае файл схемы описывает формат текстового файла; в этом
примере фактически один к одному воспроизводятся поля таблицы
в логическое определение полей в .sch-файле }
for i := 0 to FieldCount - 1 do
oTxt.Fields[i].AsString := Fields[i].AsString;
oTxt.Post;
Next;
end;
end;
finally
Table1.EnableControls;
if Assigned(oTxt) then
oTxt.Free;
end;

end;

Использование драйвера ASCII для файлов с разделительной запятой

Вторник, 06 Октября 2009 г. 22:09 + в цитатник
Delphi (и BDE) имеют способность использовать ASCII файлы для хранения таблиц. Драйвер ASCII имеет возможность транслировать значения данных ASCII-поля фиксированной длины или файла с разделительной запятой в поля и величины, которые могут отображаться компонентом TTable. Трансляция ASCII файла целиком зависит от сопровождающего файла схемы (Schema File). Файл схемы для файла ASCII данных определяет различные атрибуты, необходимые для преобразования данных ASCII файла в значения отдельных полей. Определения полей для файла с ASCII полями фиксированной длины достаточно простая задача, необходимо знать позиции всех полей, для всех строк они одинаковы. Для файлов с разделительной запятой данный процесс чуть более усложнен из-за того, что не все данные в таком файле во всех строках имеют одинаковую длину. Данный совет как раз и концентрируется на описании этой трудной темы, связанной с чтением данных из файлов с разделительной запятой, имеющих варьируемую длину поля.


Файл схемы

Файл схемы для файла данных ASCII содержит информацию, которая определяет оба типа файла (версии с разделительной запятой и полем с фиксированной длиной), а также определяет поля, которые представлены значениями данных в каждой строке файла данных ASCII. (Все поля файла схемы нечуствительны к регистру, поэтому написание "ascii" равнозначно написанию "ASCII".) Для того, чтобы файл схемы был признан в качестве такового, он должен иметь то же имя, что и файл данных ASCII, для которого он содержит схему, но иметь расширение .SCH (SCHema - схема). Атрибуты описания файла:
File name: Располагаемый в квадратных скобках, данный атрибут определяет
имя файла ASCII данных (с расширением имени файла,
которое должно быть .TXT).

Filetype: Определяет, имеет ли файл ASCII данных структуру файла с
полями фиксированной длины (используется атрибут FIXED) или
файлом с разделительной запятой (со значениями данных, которые
потенциально могут изменять длину (используется атрибут VARYING).

Delimiter: Определяет символ, которым "окантуривают" значения данных типа
String (обычно двойные кавычки, десятичный ASCII код 34).

Separator: Определяет символ, который используется для разделения отдельных
значений данных (обычно запятая). Данный символ должен быть
видимым символом, т.е. не может быть пробелом (десятичный ASCII
код 32).

CharSet: Определяет драйвер языка (используется атрибут ASCII).
Расположенные ниже атрибуты файла являются определениями поля, задающими правила для каждой строки файла данных ASCII. Данные определения служат источником информации для Delphi и BDE, первоначально необходимой для создания виртуального поля в памяти, в свою очередь служащее для хранения значений данных; тип данных виртуального поля определяется после чтения и трансляции данных из ASCII файла, определения размера и применения атрибутов. Различные атрибуты, определяющие поле файла данных ASCII:

Field: Имя виртуального поля (всегда будет "Field"), сопровождаемое
целым числом, определяющим порядковый номер поля относительно
других полей в файле данных ASCII. Например, первое поле -
Field1, второе Field2, и т.д..

Field name: Определяет выводимое имя поля, отображаемое в виде
заголовка колонки в TDBGrid. Соглашения имен для
таблиц ASCII такие же, как и для таблиц Paradox.

Field type: Определяет, какой тип данных BDE должен использоваться при
трансляции значений данных каждого поля и сообщает
Delphi тип виртуального поля, которое необходимо создать.

Используйте определение Для значений типа
----------------------- ----------------------------
CHAR Символ
FLOAT 64-битное число с плавающей точкой
NUMBER 16-битное целое
BOOL Boolean (T или F)
LONGINT 32-битное длинное целое
DATE Поле Date.
TIME Поле Time.
TIMESTAMP Поле Date + Time.

(Фактически формат для значений данных даты и времени
будет определяться текущими настройками конфигурации BDE,
страница с закладкой Date.)

Data value length: Максимальная длина значения данных соответствующего поля.
Данный атрибут определяет длину виртуального поля,
создаваемое Delphi для получения считываемых значений из
ASCII-файла.

Number of decimals: Приложение к полю типа FLOAT; определяет количество цифр
справа от десятичной точки; необходимо для включения в
определение виртуального поля.

Offset: Отступ от начала строки, позиция начала данных описываемого
поля; задается для всех строк файла.
Например, приведенное ниже определение поля относится к первому полю таблицы ASCII. Данная строка определяет значения данных типа String с именем "Text", максимальная длина значения данных составляет три символа (и в Delphi компонентах для работы с базами данных, типа TDBGrid, поле будет отображаться только тремя символами), десятичный порядок (значение данных типа String никогда не сможет иметь десятичные значения, тем более после запятой), и смещение относительно нулевой позиции (поскольку описываемая область первая, то она сама начинается с нулевой позиции, перед ней не находится ни одно поле).

Field1=Text,Char,3,00,00
Вот пример файла схемы с тремя полями, первое поле имеет тип String, второе и третье тип Date. Данный файл схемы должен содержаться в файле с именем DATES.SCH и обеспечивать определения полей для файла данных ASCII с именем DATES.TXT.
[DATES]
Filetype=VARYING
Delimiter="
Separator=,
CharSet=ascii
Field1=Text,Char,3,00,00
Field2=First Contact,Date,10,00,03
Field3=Second,Date,10,00,13
Данная схема определяет поле с разделительной запятой, где все данные могут быть отнесены к типу String, значения полей "окантурены" двойными кавычками и отдельные значения полей разделены запятой (за исключением любых запятых, которые могут находится между разделительными запятыми, внутри отдельных значений полей типа String). Первое поле типа character имеет длину три символа, без определения десятичного порядка и с нулевым отступом от начала строки. Второе поле данных имеет длину 10, без определения десятичного порядка и отступ, равный трем. Третье поле данных имеет длину 10, без определения десятичного порядка и отступ, равный 13.

Для чтения файлов ASCII с разделительной запятой, параметры длины и отступа для определения поля относятся не к значениям данных в файлах ASCII (что явно противоположно для файлов с полями фиксированной длиной), а к виртуальным полям, определяемым в приложении, в котором будет размещены считываемые данные. Параметр длины должен отражать максимальную длину значений данных для каждого поля, не считая огриничительных кавычек и разделительной запятой. Это наиболее трудно при оценке значений данных типа String, поскольку фактическая длина значений данных может быть существенно различаться для каждой строки в файле данных ASCII. Параметр отступа для каждого поля не будет являться позицией значений данных в файле ASCII (что относится к файлам с полями фиксированной длины), а представляет собой совокупную длину всех предыдущих полей (и снова, определение полей в памяти, не значения данных в файле ASCII).

Вот файл данных с именем DATES.TXT, который соответствует описанному выше файлу схемы:
"A",08/01/1995,08/11/19955
"BB",08/02/1995,08/12/1995
"CCC",08/03/1995,08/13/1995
Максимальная длина фактических значений данных в первом поле составляет три символа ("CCC"). Поскольку это первое поле и предшествующих полей не существует, отступ для данного поля равен нулю. Длина первого поля (3) используется в качестве отступа для второго поля. Длина второго поля, значение date, равно 10 и отражает максимальную длину значения данных этого поля. Совокупная длина первого и второго полей используется в качестве значения отступа для третьего поля (3 + 10 = 13).

Только когда соответствующая длина значения данных ASCII файла или длина каждого поля добавляется к длине предыдущих полей, вычисляется значение отступа и получается позиция очередного поля, только тогда данный процесс правильно считает данные. Если из-за неправильных установочных параметров в файле схемы данные транслируются неверно, то в большинстве типов полей могут возникнуть неблагоприятные эффекты типа обрезания строк, или интерпретирование цифр как нулей. Обычно в таком случае данные выводятся, но ошибки не возникает. Тем не менее, значения определенного формата в процессе трансляции в подходящий тип данных могут вызвать ошибку, если считываемые символы не соответствуют символам, например, в типе date. В контексте вышесказанного, ошибка с типом datе может возникнуть и-за того, что при неправильном определении в значения данных могут попасть данные другого, соседнего поля. При таком стечение обстоятельств трансляция данных прерывается, и в файле схемы требуется установка правильной длины поля и его отступа.

Без заголовка

Вторник, 06 Октября 2009 г. 21:47 + в цитатник
Наш портал создан именно для тебя, у нас Вы найдете бесплатный варез, сможете скачать бесплатно фильмы, скачать новую музыку, бесплатные последнии новинки игр. По просьбе посетителей, мы создали раздел скачать софт бесплатно, он пополняется всеми популярными и бесплатными программами. Для семейных любителей, создан разделы: скачать сериалы и скачать бесплатно мультфильмы. Отдельное место нашего популярного сайта занимает подготовка материалов скачать книги, и скачать картинки. Любой софт, музыку, фильмы, рингтоны можно найти для Ваших мобильныйх телефонов в разделе скачать мобилу. Мы работаем для Вас уже больше 3 лет, и на наших страницах всегда свежие и новые фильмы 2009 года, популярная музыка любых направлений, легальный софт и программы для Вашего ПК. Наш девиз: "Минимум рекламы, больше халявы". Все материалы можно скачать бесплатно, без регистрации и без SMS обманов.

avito_usershop

Вторник, 06 Октября 2009 г. 19:36 + в цитатник
Своё дело только-только только начинало набирать обороты. Нужно было делать свой сайт, чтобы придать популярности своему бизнесу и продукции. Времени было мало, ресурсов тоже немного и тут появился в поле внимания новый сервис - виртуальный магазин. Сначала отнеслись к нему скептически, но уже через некоторое время поняли, что это отличный ресурс для экономии своего времени и своих сил. Всего за полчаса уже был готов прайс-лист с подробным описанием товара. Посещаемость ресурса впечатляет - сто тысяч человек в день, таким образом теперь даже собственным сайт не нужен.
Всем, кто хочет сэкономить свои силы на периферийные вопросы и направить силы на дело - рекомендую этот сервис!
виртуальный прайс-лист

Кардшаринг

Вторник, 06 Октября 2009 г. 19:18 + в цитатник
http://cardsharing-server.ru/
Сайт посвящен цифровому спутниковому телевидению. Сайт предоставляет возможность подключения к кардшарингу. Чтобы клиент сам мог выбрать все необходимые настройки, ему предоставляется возможность тестового режима работы с системой. Тестовый режим бесплатный!
Всю необходимую информацию о кардшаринге (например, рекомендуемые протоколы связи) вы можете узнать прямо на главной странице интернет ресурса.
кардшаринг

Как правильно целоваться

Понедельник, 05 Октября 2009 г. 23:42 + в цитатник
Скорее всего, никто из Вас никогда не обращал внимания, что мы привыкли целоваться по несколько раз в день. С раннего детства и до самого конца жизни, мы целуем своих родителей, детей, близких людей и даже любимых животных. Поцелуем можно выразить свою любовь, страсть, привязанность, нежность, благодарность, выразить свое согласие, объявить о перемирии, в общем, множество самых разных чувств.
МирСоветов предлагает поговорить о «взрослых» поцелуях. Согласитесь, всегда хочется предстать перед своим партнером в самом лучшем свете, показать, на что Вы способны, порой даже удивить. Ведь если опытные Казановы всегда пытаются отточить свое мастерство, что тогда говорить об нас, о смертных и обычных людях, жаждущих нежности и ласки или о тех, кто еще не испытал этого головокружительного «поцелуйного» удовольствия?
Люди стремятся научиться целоваться для того, чтобы удовлетворить свою естественную потребность. Эта потребность также реальна, как и нужда в еде, в питье, в любви, в постоянном подключении к Интернету…
Эта нужда в страсти и необходимость дотронуться до кого-то, заключить в свои объятья своего любимого человека обычно приводит двух людей друг к другу. Стремление к человеческому контакту происходит по велению инстинкта, оно приходит естественно, и не может быть объяснено. Не смотря на это, технику поцелуя можно объяснить. А научиться целоваться может каждый.
Искусство поцелуя
Итак, что же сделать для того, чтобы первый «взрослый» поцелуй запомнился Вам и Вашему избраннику навсегда?
Не стесняйтесь. То, что Вам, может быть, еще ни разу не приходилось целоваться, еще ни о чем не говорит. Поверьте, то, что у Вас кружится голова, дрожат коленки и вдруг вспотели ладони – это всего лишь признаки того, что Вы действительно влюблены. Это ничто, по сравнению с тем, какое эмоциональное и физическое удовольствие вы получите от первого поцелуя.
Если есть возможность, сделайте окружающую обстановку интимной и романтичной. Прекрасно подойдут свечи или неяркие лампы.
Не забудьте про Ваше дыхание. Несвежий запах изо рта может отбить у девушки всякую охоту целоваться. Если вы не успели почистить зубы, к Вам на помощь придет жевательная резинка, яблоко или несколько веточек петрушки.
Во время поцелуя не замирайте в одной позе. Нежно проведите рукой по волосам партнера, коснитесь его ушей, погладьте плечи, спину.
Не молчите. Если вы целуетесь, это еще не значит, что вы должны молчать как рыба. Скажите своему любимому (или любимой) что-нибудь нежное и приятное.
Не напрягайтесь, будьте расслабленными. Напряженные губы могут, наоборот оттолкнуть Вашего партнера, либо он подумает, что доставляет Вам какие-либо неудобства.
Не останавливайтесь на одном виде поцелуя. Многие мужчины предпочитают «французский» поцелуй, или как его еще называют «мокрый» поцелуй. Поверьте, нежное покусывание и посасывание губ партнера, могут привести его в еще больше возбуждение, чем просто «общение» с Вашим языком.
Как понять, что девушка уже «созрела» для поцелуя? Можете не верить, но чаще всего, она сгорает от нетерпения и ждет, когда же ее избранник, наконец, осмелится поцеловать её первым? Обычно так происходит потому, что парень очень долго не может собраться с духом, ставя себя этим в какие-то временные рамки, и создавая неудобные ситуации. Если девушка смотрит Вам в глаза, и не пытается отвести взгляд в сторону – она дает Вам ясно понять, что уже готова целоваться, и не стоит больше тянуть.
Женщины, что, кстати, не всегда верно, считают, что по поцелую мужчины можно определить, какой у него характер, насколько он подходит и достоин ли он того, чтобы перейти с ним в более интимные отношения. Но Вы не бойтесь показать себя, откройтесь своей любимой.
Как можно определить, умеете ли Вы хорошо целоваться?
Самое главное – следить за реакцией партнера. Скорее всего, это волнует больше мужчин, чем женщин. Если женщина тихо постанывает или удовлетворенно уносится в бездну вашего безграничного поцелуя – это сразу заметно, и Вы уж точно поймете, что впросак не попали. Если же у Вашей партнерши вид такой, словно она сидит на лекции по философии – задумайтесь, что же сделать такого, чтобы ее завести? Помните, нет ничего лучше, чем достигать желанного результата методом проб и ошибок, это же касается вопроса, как научиться целоваться. Сегодня, может, у Вас и не вышел распрекрасный поцелуй, зато завтра, Вы, учтя все нюансы, поцелуете Вашу любимую так, что она будет готова взорваться от удовольствия… Женщины умеют притворяться и обманывать, но во время поцелуя, они обычно забывают о своих способностях, и не скрывают своих чувств.
МирСоветов советует обратить внимание на некоторые «приметы», которые ясно скажут Вам о том, что следует немного подучиться целоваться. Например, если девушка закрывает рот, отвлекается, отводит глаза, или, не дай Бог, уснула вся в ваших слюнях – то это первый признак того, что Вы что-то делаете не так. Если она сразу после поцелуя спрашивает про последние политические новостные сводки, или говорит что-нибудь неприятное, дав Вам понять, что Вы ей как «целователь» неинтересны – вперед, включайте всю свою фантазию и вперед к победе – практика, практика и еще раз практика!
Самая большая ошибка при поцелуе
Вы забыли о Вашей партнерше. Вы хотите целоваться только для себя, получая огромное удовольствие, и думаете, что раз этот поцелуй нравится Вам, то он обязательно нравится и Вашей партнерше. Но МирСоветов хотел бы напомнить, что у нее ведь тоже есть предпочтения, чувства, ожидания и Вы сделаете очень неправильно, если проигнорируете их.
Если Вы считаете, что Ваш широко раскрытый рот затмит все ожидания Вашей возлюбленной, то опять же, вы глубоко заблуждаетесь. Не стоит, конечно и зажимать губы, как будто Вы партизан, и никому ничего не скажете – стремитесь найти компромисс, Ваша партнерша обязательно покажет, как ей нравится целоваться. Отвечайте взаимностью, а она, в свою очередь ответит Вам.
Как же научиться целоваться лучше?
Практикуйтесь. Тренируйтесь. Все приходит с опытом. Лучший способ научиться целоваться – собственное воображение. Ваша фантазия иногда может проделать такое, что Вы даже не сразу поймете, что эти страстные поцелуи не потрясающая реальность, а всего лишь ваше воображение.
Итак, устройтесь поудобнее и расслабьтесь. Представьте перед собой предмет Вашего обожания. Представьте, как Вы приближаетесь к ней, запускаете Вашу руку в ее волосы, как вы начинаете нежно целоваться. Главное – вложить в такое фантазирование побольше эмоций и чувств. Чем ярче будет картинка – тем лучше для Вас, так как Вы не потратили время на репетиции зря.
И, напоследок, МирСоветов скажет об одном важном моменте! Научиться целоваться только в губы недостаточно. У особей слабого пола, есть масса эрогенных зон. Благодаря нашим вездесущим исследователям-социологам, известно, что 97 процентов женщин от поцелуя в шею возбуждаются моментально, а иногда чуть ли не достигают до оргазма. Всего-то и стоит, что подойти к любимой, крепко обнять сзади, откинуть ее волосы и нежно поцеловать. Когда девушка чувствует горячее мужское дыхание на шее, его покусывания и поцелуи – она просто готова раствориться в объятьях!

Поцелуй – это блаженство, во время которого соединяются души влюбленных. Не бойтесь экспериментировать. Целуйте Вашего возлюбленного так, как Вам подсказывает Ваше сердце. Вы всегда будете хранить в памяти воспоминания о таких поцелуях.

Без заголовка

Понедельник, 05 Октября 2009 г. 23:41 + в цитатник
Секреты Вконтакте (vkontakte.ru): 0. Узнавайте обо всех событиях сразу!

Хотите сразу узнавать о новых сообщениях, комментариях к вашим фотографиям, новых статусах друзей и многих событиях Вконтакте? Тогда обязательно установите бесплатную программу «Агент Вконтакте». С ее помощью вы запросто сможете менять свой статус, добавлять в друзья, видеть обновления у ваших друзей а также переписываться с ними так, как это происходит, например, в ICQ. Об обновлениях программа сигнализирует специальным окошком в трее (рядом с часами) что очень удобно. При этом программа не нагружает ваш ПК и позволяет использовать прокси (что особенно актуально для тех, кто работает в офисе и не может жить без «Вконтакте»). Скачивайте «Агент Вконтакте» — будьте онлайн!

Секреты Вконтакте (vkontakte.ru): 1. Просмотр закрытых страниц (профилей)

Это один из самых желанных секретов. Ну кто хоть раз не мечтал посмотреть фотографии шикарной незнакомки, при этом не добавляя ее в друзья? А если доступ к ее странице закрыт? Выход есть! Итак, секрет довольно прост. Необходимым условием является открытость фотоальбома, видеозаписей, аудиозаписей, заметок и т.д. Для начала нужно узнать ID пользователя. Как узнать ID «Вконтакте»? Очень просто! ID — это номер, который идет в УРЛ после «http://vkontakte.ru/id». Например у Павла Дурова ID 1, а у меня — 17110449 (добавляйте в друзья, я не против). После того, как вы узнали ID остается только подставить его в нужный УРЛ. Ниже представлен список «секретных» УРЛ для доступа к различным разделам пользователя. Вместо «*» подставляйте ID нужного вам пользователя.

Записи на стене:
http://vkontakte.ru/wall.php?id=*

Фотоальбомы:
http://vkontakte.ru/photos.php?id=*

Видеозаписи:
http://vkontakte.ru/video.php?id=*

Аудиозаписи:
http://vkontakte.ru/audio.php?id=*

Заметки:
http://vkontakte.ru/notes.php?id=*

Группы:
http://vkontakte.ru/groups.php?id=*

Секреты Вконтакте: 2. Специальные символы для «Вконтакте»

Вы, наверное, замечали, что у некоторых пользователей в имени, статусе или просто в профиле имеются прикольные необычные символы. С клавиатуры их, естественно, ввести нельзя, но секрет прост. Эти символы называются специальными и вводятся посредством HTML кода. Узнать какой код для какого символа «Вконтакте» нужен можно тут. По этому адресу вы найдете практически все коды для «Вконтакте».

Секреты Вконтакте: 3. Лишаемся имени (как убрать имя и фамилию)

Многие хотели бы быть инкогнито как в жизни, так и «Вконтакте». Вы все видите, все знаете, а о вас не знает никто. Это возможно! Вы с легкостью можете создать себе аккаунт без имени. Секрет с одним небольшим минусом — для начала вам нужно будет зарегистрироваться заново.
Заново регистрируемся «Вконтакте». Заполняем все поля кроме «Имя» и «Фамилия».
Копируем в адресную строку браузера код: javascript: this.disabled=true; document.regMe.submit();
Нажимаем «Enter» или кнопочку «Переход» в браузере.
Готово! Вы зарегистрированы без имени и фамилии!

Секреты Вконтакте: 4. Становимся невидимым

Еще один способ приблизиться к человеку-невидимке. Благодаря этому секрету вы сможете ходить по страницам социальной сети, а другие пользователи будут думать, что вы в оффлайне. Но при этом нельзя посещать страницу «profile.php», т.е. свой профиль и главные страницы профилей других пользователей. Есть 3 способа, точнее секрета:

Секрет № 1 (подходит только для Firefox)
Вводим в адресную строку Firefox «about:config». Появятся настройки браузера.
Нам нужно временно запретить переадресацию. Для этого в поле «Фильтр» вводим «network.http.redirection-limit» и меняем его значение на 0. У меня по умолчанию он равнялся 20-ти.
Открываем новую вкладку и заходи на страницу http://vkontakte.ru/login.php и вводим логин и пароль.
Появится сообщение об ошибке. Не волнуйтесь, так и должно быть.
Идем на любую другую страницу «Вконтакте» (кроме «profile.php»).
Возвращаемся на вкладку с настройками и обратно меняем параметр «network.http.redirection-limit» на то, что было по умолчанию.

Секрет № 2 (подходит только для Opera)
Заходим в «Инструменты» > «Настройки» > «Дополнительно» > «Сеть».
Убираем галочку «Включить автоматическое перенаправление».
Повторяем действия для браузера Firefox, начиная с 3 пункта.

Секрет № 3 (простой, но требует времени)
Заходим в раздел «Личные сообщения»
Ждем 15 минут (тайм-аут для соединения с «Вконтакте»).
Все готово. Можно перемещаться по страницам социальной сети, кроме «profile.php».

Секрет № 4

Тоже самое можно сделать при помощи программы Vk A-Vision. Речь о программах для «Вконтакте» пойдет в одном из следующих постов. Обязательно подписывайтесь на RSS, чтобы не пропустить.

Секреты Вконтакте: 5. Как жениться на себе

Особой пользы в этом секрете нет, но выделиться перед друзьями все же хочется. Жениться на себе довольно просто. Для началу объясню как это делает в браузере Opera. Заходите на страницу редактирования своего профиля (http://vkontakte.ru/profileedit.php) и открываете исходный код этой страницы. ищите код выпадающего списка и в самом конце добавляете себя . Нажмите «Применить изменения» и на странице редактирования выбираете себя. После чего остается лишь сохранить профайл. Такую же операцию можно проделать и в браузере Firefiox, но для этого вам нужно установить плагин Firebug.
Самые свежие секреты «Вконтакте» здесь! Не пропустите!

Секреты Вконтакте: 6. Отмечаем всех друзей на виде

Отмечать друзей на видео вручную долго и мучительно. Проще сделать это используя следующий секрет. Он содержит всего 4 шага:
Заходим на страницу с нужным видео.
Нажимаем «Отметить».
В адресную строку браузера вставляем скрипт: «javascript:for(blabla=0;blabla<5000;blabla++){ var elem = document.getElementById('f'+blabla); if(elem == null) break; elem.onclick(); }».
Нажимаем «Enter».

Секреты Вконтакте: 7. Отрицательный рейтинг

На мой взгляд абсолютно бесполезная вещь, но все же кому-нибудь может пригодиться. Сначала нужно добиться, чтобы на вашей странице вверху было написано «Информация на данной странице может не соответствовать действительности.» Как это сделать? Просто. Создайте страницу какой-нибудь звезды, выложите парочку фотографий Мерилин Монро и подпишите, что это вы. Профиль должен быть заполнен на 100% — это обязательное условие. Иначе секрет не сработает. Затем отпишитесь в одной из групп, в которых есть модераторы. Как только получите долгожданное сообщение «Информация на данной странице может не соответствовать действительности.» начинайте удалять информацию со страницы. Например, если удалить аватар рейтинг станет -30%.

Секреты Вконтакте: 8. Смена язык

С помощью этого простейшего секрета можно отлично разыграть друга. Суть в следующем: при переходе по ссылке http://vkontakte.ru/?lang=цифра язык меняется с русского на тот, цифру которого вы указали. Русский язык — 0. А дальше экспериментируйте! Не забудьте написать хороший зазывающий текст. Например: «http://vkontakte.ru/?lang=10 — специальная Новогодняя Версия Вконтакте! Заходи — не пожалеешь!».

Секреты Вконтакте: 9. Отменяем заявку на добавление в друзья

Иногда бывает такое: добавили в друзья человека, а потом передумали. Не беда, заявку можно удалить, точнее отменить. Введите в адресную строку браузера http://vkontakte.ru/friend.php?act=remove&id=*, где * — ID ненужного друга. После этого появится сообщение: «Вы точно хотите удалить Имя_друга Фамилия_друга из числа друзей?». Смело нажимайте «Да».

Секреты Вконтакте: 10. Статус на несколько строк

Как и другие секреты, этот довольно прост. Единственное условие — нам нужен браузер Opera. Открываем страницу своего профиля и переходим в режим просмотра исходного кода.Находим следующий кусок кода:

«»

Заменяем его на:

«»

Сохраняем результат. Теперь вы можете писать статус «Вконтакте» в несколько строк.

Секреты Вконтакте: 11. Вставляем музыку в заметку «Вконтакте»

На самом деле очень полезная функция. Если вы храните огромное количество треков, можно создать некое подобие плейлистов при помощи заметок. Нас ждут 5 шагов. Приступим.
Находим нужную нам песню. Сделать это можно по адресу vkontakte.ru/audio.php.
Рядом с песней есть ссылка «Добавить». Копируем ее. Сделать это можно следующий образом: открываете ее в новом окне и сразу останавливаете загрузку страницы. У меня получилась вот такая ссылка: audio.php?act=add&add=1&gid=0&aid=47083679&oid=-4536434&hash=5ba68fca77ce808a3947297722874e55
Копируем из этой ссылки числа, который идет после &oid= и &aid=.
Вставляем эти числа в [[audio*_**]«]», где * — число после &oid, ** — число после &aid.
Вставляем полученный тег в заметку. У меня получилось [[audio-4536434_47083679]]. Все работает.

Секреты Вконтакте: 12. Секреты граффити «Вконтакте»

Часто задавались вопросом как у некоторых пользователей получаются шикарные граффити? Секреты как всегда просты и лежат на поверхности.
Чтобы нарисовать прямые горизонтальные и вертикальные линии нужно переключить управление мыши на дополнительную клавиатуру. Делет это просто комбинацией — Shift+Alt+NumLock.
Работа с масштабом поможет вам лучше прорисовать мелкие детали. Можно увеличить масштаб в браузере а можно воспользоваться стандартной функцией Windows — «Экранная лупа». Чтобы включить ее нужно зайти: Пуск > Все программы > Стандартные > Специальные возможности > Экранная лупа.

Секреты Вконтакте: 13. Следим за людьми

Вы хотели бы знать как часто ваш друг сидит «Вконтакте»? А ваша девушка? А ваши подчиненные, вместо того, чтобы работать? Думаю да. Именно для этого и создан сервис SocialWatch.ru. С помощью этого «секретного» сервиса вы с легкостью сможете проследить за нужными вами людьми. Как обычно все просто: нужно пройти быструю регистрацию, добавить аккаунт нужного вам человека в список и все! Можно следить как много времени человек проводит в социальной сети. Секрет «Вконтакте» раскрыт.

Секреты Вконтакте: 14. Если вам заблокировали «Вконтакте»

Этот секрет будет особенно вам полезен, если у вас на работе или в учебном заведении заблокировали «Вконтакте». Выход как всегда есть. Даже если «Вконтакте» заблокирован все равно можно зайти в социальную сеть, причем двумя разными путями. Самый быстрый и простой способ — скачать программу «Агент Вконтакте» и использовать прокси сервера, которые можно найти в Интернете совершенно бесплатно. Второй способ — вход через анонимайзер. Некоторые анонимайзеры также могут быть заблокированы, но я думаю из предложенного ниже списка один рабочий точно найдется.

www.proxya.ru
www.hidemyass.com
www.proxyfoxy.com
www.iternovus.com
www.proxyguy.com
www.proxyhero.com
www.shadowsurf.com
www.timp.ru/content/view/59/68/
mecto.net/cgi-bin/pro.cgi
www.proxy.dnsserv.ru/
www.kproxy.com/
browseatwork.com/

Проблема с заблокированным «Вконтакте» решена.

Секреты Вконтакте: 15. Узнать автора анонимного мнения

Сразу стоит оговориться, что этот секрет работает не всегда. Но попробовать можно. Итак, чтобы узнать автора анонимного мнения «Вконтакте» требуется:

В Разделе “Предложения” создаем новое предложение. Постарайтесь придумать что-нибудь интересное.
После этого включаем “Предложения” в разделе “Мои Настройки”.
Отправляем автору мнения следующую ссылку http://vkontakte.ru/matches.php?act=a_sent&to_id=***&dec=1, где *** — ваш ID «Вконтакте». Как узнать ID я уже писал выше. Ссылка должная «комплектоваться» интересным текстом, чтобы аноним кликнул по ней.

Как только аноним щелкнет на ссылку, вы получите подтверждение соглашения предложению. Таким образом мы и вычислим кто именно это был. Но подтвердить ваше предложения в данном случае сможет лишь один человек.

Секреты Вконтакте: 16. Как посмотреть закрытые фотографии «Вконтакте»

Это свежий секрет, который стал известен после Нового Года. Алгоритм действий следующий:
Включаем свежеиспеченную функцию — «Ускоренный режим просмотра фотографий».
Идем в раздел «Фотографии на которых отмечен пользователь» (нужно чтобы он был открыт). Обычно там большинство фотографий закрыты для просмотра.
Выбираем фотографию, которая открыта и дальше уже стрелочками или кликом по фотографии как обычно просматриваем альбом. Все закрытые фотографии будут вам видны.

Этот секрет «Вконтакте» работает благодаря новой функциий «Ускоренный режим просмотра фотографий», которая реализована немного криво.
http://koreps.ru/sekrety-vkontakte/

Модуль crt и создание консольных интерфейсов

Понедельник, 05 Октября 2009 г. 23:36 + в цитатник
Модуль crt содержит процедуры и функции, предназначенные для работы с экраном консоли в текстовом режиме. Как и ряд других стандартных модулей, crt встроен в компилятор и содержится в файле turbo.tpl.

Экран в текстовом режиме разбивается на отдельные строки, а каждая строка -- на позиции, причем в каждую позицию может быть помещен только 1 символ из набора ASCII.

Для полного описания экранной позиции кроме символа следует задать еще и атрибут, содержащий информацию о цвете символа и фона на экране. Символ и атрибут занимают в памяти по 1 байту. Структура байта-атрибута показана на рис. 24.1.





Рис. 24.1. Структура байта-атрибута консоли



Старший бит 7 управляет мерцанием символа (символ на экране мерцает, если он установлен в 1), биты 4-6 содержат цвет фона (кодируется двоичными числами от 0 до 7 включительно), а биты 0-3 -- цвет символа (от 0 до 15). Разумеется, программисту обычно не приходится заполнять байт атрибута по битам, для этого есть стандартные коды цветов. Основные цвета кодируются цифрами от 0 до 15, причем цвет текста может быть любым, а цвет фона -- только из первых 8 цветов. Все цвета описаны в табл. 24.1.





Табл. 24.1. Коды и наименования стандартных цветов
Код
Наименование
Цвет

0
BLACK
черный

1
BLUE
синий

2
GREEN
зеленый

3
CYAN
циановый

4
RED
красный

5
MAGENTA
фиолетовый

6
BROWN
коричневый

7
LIGHTGRAY
светло-серый

8
DARKGRAY
темно-серый

9
LIGHTBLUE
голубой

10
LIGHTGREEN
светло-зеленый

11
LIGHTCYAN
светло-циановый

12
LIGHTRED
светло-красный

13
LIGHTMAGENTA
светло-фиолетовый

14
YELLOW
желтый

15
WHITE
белый




Можно обращаться к цвету как по цифровому коду, так и по англоязычному имени.

Широко используемые текстовые режимы имеют в окне консоли 25 строк по 80 столбцов (позиций) в строке. Нумерация строк и позиций начинается с 1 и считается слева направо и сверху вниз. Весь экран в текстовом режиме может быть описан парой координат (1, 1), (80, 25). Обратите внимание на порядок записи -- столбец, затем строка.

Ниже рассмотрены основные процедуры и функции модуля. Везде для краткости введены следующие обозначения:

x,x1,x2 -- координаты столбцов экрана;

y,y1,y2 -- координаты строк экрана;

c -- значение цвета.

Особенность модуля crt состоит в том, что он позволяет работать не только со всем экраном, но и с выделенным на нем прямоугольным окном. При этом весь ввод, вывод и прокрутка текста происходят в пределах окна. По умолчанию размеры окна совпадают с размерами экрана, но можно явно установить их обращением к стандартной процедуре Window (x1,y1,x2,y2);, где (x1, y1) и (x2, y2) -- соответственно, левый верхний и правый нижний угол окна.

Цвет фона окна c задает процедура textbackground ( c );, а цвет символов -- textcolor ( c );.

Процедура без параметров clrscr; очищает текущее окно цветом фона.

Для установки текстового курсора в позицию окна с координатами (x, y) определена процедура gotoxy (x,y);.

Программно определить текущее положение курсора позволяют 2 стандартные функции Wherex:char; и Wherey:char;, возвращающие, соответственно, текущие x- и y-координату курсора.

Процедура ClrEol; удаляет все символы от позиции курсора до конца строки включительно, заполняя этот участок цветом фона.

Процедура Delline; полностью удаляет строку, в которой находится курсор, а Insline; вставляет пустую строку на экране в месте расположения курсора и заполняет ее цветом фона. Обе процедуры обеспечивают прокрутку содержимого окна.

Процедура Sound (F:word); включает встроенный динамик с частотой F герц, обеспечивая выдачу звукового сигнала.

Процедура Delay (T:word); задает задержку выполнения программы, равную T миллисекунд (1000 мс = 1 сек.). Эта процедура используется для организации задержек выполнения программы, а также всегда вызывается после sound, чтобы определить время звучания динамика.

Процедура без параметров NoSound; выключает динамик. Обязательно используется после пары Sound и Delay.

Наконец, в модуле crt определены 2 стандартных функции для работы с кодами нажатых клавиш. Функция readkey:char; возвращает код символа, прочитанный из буфера клавиатуры. Функция keyPressed:boolean; возвращает значение true, если была нажата клавиша на клавиатуре (за исключением вспомогательных клавиш Alt, Shift, Ctrl и т. д.). Использование последней функции позволяет организовать циклы, выполняющиеся до нажатия какой-либо клавиши.

При запуске программы из оболочки Паскаля монитор находится обычно в текстовом режиме и устанавливать его не нужно. Тем не менее, существует стандартная процедура textMode (Mode:integer), устанавливающая текстовый режим с номером Mode.

Стандартный цветной текстовый режим 25*80 позиций имеет номер 3, цветной текстовый режим 25*40 позиций -- номер 1.

Модуль crt содержит также системные переменные, которые можно изменять в соответствии с указанным для них типом.

Переменная CheckBreak:boolean; управляет реакций программы на прерывание по сочетанию клавиш Ctrl+Break. По умолчанию переменная имеет значение true (реакция включена).

Если переменная DirectVideo:boolean; имеет значение true, процедуры вывода на экран пишут данные непосредственно в видеопамять, не используя операционную систему. Это ускоряет вывод, но может использоваться только на полностью IBM-совместимых ЭВМ.

Переменная textAttr:integer; содержит текущий атрибут текста, сформированный по описанным выше правилам.

Приведем пример программы, определяющей коды нажатых клавиш. Конструкция repeat ... until в этой программе является образцом обработки ввода с клавиатуры. Проблема состоит в том, что функция readkey возвращает однобайтовый код клавиши, а ряд клавиш и сочетаний клавиш имеют двухбайтовые коды. С этим связан второй вызов функции readkey в программе.

uses crt;

var ch : char; {Символ, который вводим}

begin

clrscr; {Очистили экран}

writeln ('Программа выводит коды клавиш;',

' Esc - выход.');

repeat

writeln('Нажмите клавишу:');

ch := readkey; {Ждем ввода символа}

if ch = #0 then {Если нажата спец.

клавиша, то функция вернула 0,}

begin

ch := readkey; {и нужно прочитать код

символа дополнительно}

writeln('Нажата специальная клавиша ',

'с кодом ', ord(ch));

end

else {Иначе если нажата обычная клавиша -

сразу видим ее код}

writeln('Нажата клавиша с ASCII-кодом',

' ',ord(ch));

until ch=#27; {Значение 27 -

это код клавиши Escape}

writeln ('До свидания.');

end.

Как правило, в реальных программах широко используются небуквенные клавиши, такие как Enter, F1, Esc и т. д. Узнать их коды можно из таблиц ASCII-символов. Например, код клавиши Escape равен #27. Для записи клавиатурного кода на Паскале перед его значением ставится символ #, как сделано в этом примере. Более подробно об обработке нажатий клавиш рассказано в Приложении 5. Листинги 5-8 из Приложения 4 также иллюстрирует основные аспекты обработки нажатий клавиш.

В качестве развернутого примера использования функций модуля crt напишем программу, которая заполняет экран случайными цветными окнами, а также является примером проигрывания несложной "музыки" через встроенный динамик компьютера. Для рисования рамок в этой программе используются символы псевдографики, которые есть только в кодировке DOS (см. Приложение 1).

Program crt_example;

uses crt;

const minLen=10; {минимальная длина окна}

pause=500; {задержка при выводе звука}

blink=128; {установка бита мерцания}

var x1,y1,x2,y2 :integer;

{координаты окна}

background, {цвет фона окна}

color, {цвет текста}

freq, {частота звука}

setblink :integer; {есть/нет мерцание}



procedure doubleFrame (x1,y1,x2,y2:integer;

Header: string);

{Процедура рисует двойной рамкой окно

с заголовком и подготавливает его

внутреннюю часть для ввода текста}

{ x1,y1,x2,y2 - координаты окна}

{ header - заголовок окна}

var i,j: integer;

begin

Window (1,1,80,25);

{Рисуем верхнюю строку рамки }

gotoxy (x1,y1); write ('╔');

for i:=x1+1 to x2-1 do write('═');

write ('╗');

{Перебираем строки внутри окна}

for i:=y1+1 to y2-1 do begin

gotoxy (x1,i); write('║');

for j:=x1+1 to x2-1 do write (' ');

{Внутренность окна - пробелы}

write('║'); {Правая граница}

end;

{Аналогично рисуем нижнюю строку}

gotoxy (x1,y2); write('╚');

for i:=x1+1 to x2-1 do write('═');

write('╝');

gotoxy (x1+(x2-x1Length(Header))

div 2,y1);

{Ставим курсор в середину верхней строки}

write (Header); {Выводим заголовок}

Window (x1+1,y1+1,x2-1,y2-1);

{Устанавливаем текущее окно внутри рамки}

gotoxy (1,1);{Ставим курсор в левый

верхний угол нового окна}

end;



begin

textbackground (BLACK);

Window (1,1,80,25);

{окно вывода - весь экран}

clrscr;

{Инициализируем генератор случайных чисел}

randomize;

DirectVideo:=true;

while not keyPressed do begin

{Пока не нажата клавиша,

выполняется цикл}

x1:= 1 + random(80-minLen);

x2:=x1 + minLen + random (80-x1-minLen);

y1:= 1 + random(25);

y2:= 1 + y1 + random (25-y1);

{Выбрали случайные координаты окна }

background:=random(8);

color:=random(16);

{Выбрали цвет фона и текста}

setblink:=random(2);

{Выбрали установку мерцания ДА или НЕТ}

textbackground (background);

textcolor(color+blink*setblink);

{Цвет текста с учетом мерцания}

doubleFrame (x1,y1,x2,y2,' Hello! ');

{Рисуем окно с помощью процедуры}

background := (textAttr and 112) shr 4;

{ Из байта цвета, содержащегося в

переменной textAttr, выделяем цвет

фона. Операция shr xx сдвигает

байт вправо на xx бит, а 112 в

двоичной системе это 01110000

(включены биты, отвечающие за фон) }

case background of

{ В зависимости от цвета фона выбираем

частоту звучания динамика }

0: freq:=262; {Частота ноты До}

1: freq:=294; { -"- Ре}

2: freq:=330; { -"- Ми}

3: freq:=349; { -"- Фа}

4: freq:=392; { -"- Соль}

5: freq:=440; { -"- Ля}

6: freq:=494; { -"- Си}

7: freq:=524; { -"- До}

end;

sound (freq); {Включаем динамик}

Delay (pause);

{Ждем, пока не истечет задержка}

Nosound; {Выключаем динамик!}

end; {Конец основного цикла}

{Восстанавливаем атрибуты текста и окно}

textbackground (BLACK);

textcolor (LIGHTGRAY);

Window (1,1,80,25);

clrscr;

end.

Использование этой программы на современном быстром процессоре может и не дать вам насладиться "космической музыкой" -- проблема в реализации функции Delay, учитывающей не реально прошедшее время в миллисекундах, а "условное" время, связанное с тактовой частотой процессора. Для исправления ситуации следует написать и применять собственную реализацию Delay, привязанную к функции GetTime модуля dos, позволяющей получить "абсолютное" системное время в часах, минутах, секундах и сотых долях секунды. Ниже приводится одна из возможных версий такой функции с комментариями основных действий и тестом:

uses crt,dos;

function getlongintTime:longint;

{Вернет системное время как longint}

var Hour,minute,second,sec100: word;

var k,r:longint;

begin

GetTime (Hour, minute, second, sec100);

{Прямое вычисление по формуле

Hour*360000+minute*6000+second*100+sec100

не сработает из-за неявного

преобразования word в longint:}

k:=Hour; r:=k*360000;

k:=minute; Inc (r,k*6000);

k:=second; Inc(r,k*100);

Inc(r,sec100); getlongintTime:=r;

end;



procedure MyDelay (ms:word);

{Корректно работает с задержками

до 65 сек.!}

var endTime,curTime : longint;

cor:boolean; {признак коррекции времени

с учетом перехода через сутки}

begin

cor:=false;

endTime:=getlongintTime + ms div 10;

if endTime>8639994 then cor:=true;

{Учитываем возможный переход через сутки;

23*360000+59*6000+59*100+99=8639999 и

отняли 5 мс с учетом частоты срабатывания

системного таймера BIOS}

repeat

curTime:=getlongintTime;

if cor=true then begin

if curTime<360000 then

Inc (curTime,8639994);

end;

until curTime>endTime;

end;



var Hour,minute,second,sec100: word;

begin

clrscr;

{setTime (23,59,58,99);}

{если раскомментарить - может изменить

системное время!}

repeat

gotoxy (1,1);

GetTime (Hour, minute, second, sec100);

write (Hour:2, ':', minute:2, ':',

second:2, ':',sec100:2, ' ');

MyDelay (500);

until keypressed;

end.

В Приложении 4 приведены также листинги программ для вывода кодов часто используемых клавиш, движения по экрану "прицела" с помощью клавиш со стрелками, а также программа создания несложного двухуровневого меню пользователя (листинги 5-7).



Процитировано 1 раз

Модуль graph и создание графики на Паскале

Понедельник, 05 Октября 2009 г. 23:34 + в цитатник
Для работы с графикой из программы на Паскале в папке, откуда она запускается, должен присутствовать файл egavga.bgi. Он представляет собой графический драйвер, предназначенный для управления видеопамятью в режимах поддержки мониторов типов EGA и VGA. Разумеется, современные мониторы давно "переросли" эти два исторически распространенных класса дисплеев. Однако, на любом современном компьютере поддержка видеорежимов EGA и VGA по-прежнему возможна, если не напрямую, то через специальную программу-эмулятор (см. конец главы).

В поставку Паскаля могут входить и другие файлы с расширением *.bgi, отвечающие за работу с мониторами различных типов.

Кроме того, при компиляции программы, имеющей графический вывод, должен быть доступен модуль graph.tpu, содержащий подпрограммы отрисовки графических объектов.

Библиотека graph.tpu подключается стандартным способом с помощью директивы uses в разделе описаний программ:

uses graph;

В графическом режиме, который в современных операционных системах типа Windows является основным, экран представляет собой матрицу точек (пикселов), причем имеется возможность высветить любой пиксел любым цветом. Координаты каждого пиксела определяются парой целых чисел:

· координата x -- номер пиксела в строке. Нумерация выполняется слева направо, начиная с 0;

· координата y -- номер строки пикселов. Нумерация строк производится сверху вниз, начиная с 0.

Таким образом, координаты левого верхнего угла экрана равны (0, 0).

Любой объект, высвечиваемый на экране, является совокупностью отдельных пикселов. Количество воспроизводимых пикселов по горизонтали и вертикали зависит от типа монитора и установленного графического режима. Каждый монитор может использовать множество режимов, отличающихся количеством поддерживаемых цветов и разрешением графического экрана в пикселах.

Классический Паскаль поддерживает монитор CGA, имеющий разрешение до 3203200 пикселов, монитор EGA с разрешением 6403350, монитор VGA с разрешением до 6403480. Работу с более современными и мощными графическими устройствами, относящимися к классу superVGA, Паскаль непосредственно не поддерживает, хотя существуют созданные независимыми разработчиками графические драйверы этих режимов.

Графический режим работы экрана кроме количества пикселов характеризуется определенной палитрой -- набором видимых цветов. Каждая палитра состоит из 4 цветов для монитора CGA или 16 цветов для EGA и VGA.

Установка графического режима осуществляется путем обращения к процедуре initgraph:

initgraph(var gd:integer, var gm:integer,

pt:string);

Целочисленные переменные gd и gm задают тип графического драйвера и режим его работы, строковая переменная pt -- путь к файлу *.bgi. Например, при выборе основного для Паскаля видеорежима VGA с разрешением 6403480 пикселов и поддержкой 16 цветов подойдет следующий код:

uses graph;

var gd,gm,error: integer;

begin

gd:=VGA; {адаптер VGA}

gm:=VGAHi; {режим 640*480пикс.*16 цветов}

initgraph(gd,gm,'');

error:=graphresult;

if error <> grOk then begin

write ('Ошибка графики: ',

grapherrormsg(error));

readln; halt;

end;

line (0,0,getmaxx,getmaxy);

readln; closegraph;

end.

Так как путь к файлу egavga.bgi указан пустым, предполагается, что он находится в текущей папке. После перехода в графический режим процедурой line рисуется линия из левого верхнего в правый нижний угол экрана, затем, после нажатия Enter, графический режим закрывается и происходит выход из программы.

Для автоматического выбора максимально возможного режима переменной gd необходимо присвоить значение detect, при этом переменные gm и pt не определяются, если в текущем каталоге, в котором находится система Турбо Паскаль, имеются файлы *.bgi. Пример:

uses graph; var gd,gm: integer;

begin

gd:=detect; initgraph(gd,gm,''); ...

Рассмотрим основные стандартные процедуры и функции модуля graph.

closegraph;

- процедура без параметров, завершает работу в графическом режиме. Следует выполнять эту процедуру перед завершением любой графической программы на Паскале.

cleardevice;

- процедура без параметров, очищает экран. При переходе в графический режим экран очищается автоматически, так что перед началом вывода эта операция не требуется.

function getmaxx:integer;

- функция возвращает максимальную координату пиксела по оси x.

function getmaxy:integer;

- функция возвращает максимальную координату пиксела по оси y.

setcolor(color:word);

- процедура устанавливает цвет рисования линий, точек и текста (аналог "пера" в программах для рисования). Цвета кодируются так же, как в текстовом режиме (см. табл. 24.1).

setfillstyle (style:word, color:word);

- процедура устанавливает цвет заполнения областей экрана (параметр color) и способ наложения цвета (параметр style). Является аналогом "кисти" в программах для рисования. Параметр color принимает значения, указанные в табл. 24.1, параметр style -- значения от 1 до 11. При style=1 происходит сплошное заполнение цветом, другие стили позволяют создать различные штриховки. Здесь и далее вместо цифр можно использовать символические имена стилей, узнать о них можно в справочной системе.

Приведем примеры.

setfillstyle (linefill,GREEN);

{установили заполнение зелеными линиями}

setfillstyle (solidfill,RED);

{ установили сплошную заливку красным}

Следующая процедура определяет стиль рисования линий:

setlinestyle (linestyle:word, pattern:word,

thickness:word);

Параметр linestyle (стиль линии) принимает значения от 0 до 4, значение 0 соответствует сплошной линии, параметр pattern при использовании готовых стилей со значением linestyle от 0 до 3 игнорируется, толщина линии thickness указывается значением 1 или 3 (в пикселах). Например, оператор setlinestyle (0,0,1); устанавливает стиль сплошной тонкой линии, а setlinestyle (1,0,3); -- толстую пунктирную линию. Для цифровых значений linestyle и thickness в библиотеке также определены символические имена, при значении linestyle=4 можно определить собственный стиль, задав его параметром pattern с помощью битовой маски.

Перейдем к стандартным подпрограммам, связанным с отображением на экране основных графических примитивов.

putpixel(x,y:integer,color:word);

- процедура высвечивает на экране пиксел с координатами (x, y) цветом color;

function getpixel (x,y:integer):word;

- функция вернет код цвета пиксела с координатами (x, y).

line(x1,y1,x2,y2:integer);

- процедура рисует текущим цветом прямую линию с экранными координатами начала (x1, y1), и конца (x2, y2).

moveto(x,y:integer);

- процедура устанавливает текущую позицию рисования (пера, графического курсора) в точку с экранными координатами (x, y).

lineto(x,y:integer);

- процедура проводит прямую линию из текущей позиции пера в точку с экранными координатами (x, y). Линия проводится текущим цветом пера.

linerel(dx,dy:integer);

- процедура проводит прямую линию из текущей позиции в точку с приращением координат от текущих на dx и dy, приращения могут быть как положительными так и отрицательными. Таким образом, процедура linerel позволяет указывать, в отличие от line и lineto, не абсолютные, а относительные координаты точки, куда нужно провести линию.

rectangle(x1,y1,x2,y2:integer);

- процедура рисует прямоугольник с координатами левого верхнего угла (x1, y1) и правого нижнего угла (x2, y2). Цвет прямоугольника, как и других незакрашенных фигур, определяется установкой, сделанной процедурой setcolor.

bar(x1,y1,x2,y2);

- процедура рисует закрашенный прямоугольник с координатами углов (x1, y1) и (x2, y2). Цвет и стиль заливки определяются процедурой setfillstyle.

bar3d (x1, y1, x2, y2, depth :integer;

top:boolean);

- процедура рисует трехмерный параллелепипед. Параметр depth определяет глубину фигуры по оси x, top указывает, рисовать ли верхнюю грань:

bar3d (50,50,100,100,20,true);

Следующая процедура рисует многоугольник или ломаную линию:

drawpoly (numpoint:integer;

var polypoints);

Аналогичная процедура fillpoly создает закрашенный цветом заливки многоугольник. Покажем работу процедуры на примере:

var poly: array [1..10] of integer;

poly[1]:=20; poly[2]:=20;

poly[3]:=60; poly[4]:=30;

poly[5]:=60; poly[6]:=60;

poly[7]:=40; poly[8]:=80;

poly[9]:=20; poly[10]:=20;

drawpoly (5,poly);

Элементы с нечетными номерами массива poly задают x-координаты точек, а с четными -- y-координаты. Таким образом, в данном случае нарисован пятиугольник.

floodfill (x,y,bordercolor:integer);

- мощная процедура, позволяющая закрасить любую замкнутую область, которой принадлежит точка (x, y) и которая ограничена по краям цветом bordercolor.

circle(x,y:integer,r:word);

- несложная процедура рисует окружность с центром в точке с координатами (x, y) и радиусом r.

arc(x,y:integer,sa,ea,r:word);

- процедура рисует дугу окружности с центром в точке с координатами (x, y), радиусом r, начальным углом sa и конечным углом ea. Углы sa и ea измеряются в градусах и отсчитываются против часовой стрелки от оси абсцисс.

Существуют также процедуры для рисования эллипсов и секторов.

Для вывода текста на графический экран имеются 2 основные функции.

outtextxy(x,y:integer,text:string);

- процедура выводит текст на экран, начиная с точки с координатами (x, y). Здесь text -- константа или переменная строкового типа, содержащая нужное сообщение. Текст выводится установленным цветом рисования линий. Заметим, что применение стандартных процедур write и writeln для вывода текста в графическом режиме нежелательно, так как они не позиционируют текст по пикселам и не учитывают установок цвета и фона графического экрана.

outtext(text:string);

- процедура выводит текст, заданный параметром, на экран, начиная с текущей позиции графического курсора.

Для краткости мы не рассматриваем методы привязки текста к позициям на экране.

В библиотеке graph нет процедур для вывода численных данных. Для этого необходимо сначала преобразовать число в строку с помощью процедуры str, а затем посредством операции '+' подключить строку к сообщению, выводимому процедурой outtextxy. Например:

max:=34.56; {Число}

str(max:6:2,smax);

{Преобразование числа max в строку smax}

outtextxy(400,40,'Максимум=' + smax);

{Вывод строки smax с комментарием}

Узнать ширину и высоту строки в пикселах можно с помощью стандартных функций function textwidth (s: string):word; и function textheight (s: string):word; соответственно.

Существуют также процедуры для управления внешними графическими шрифтами, хранящимися в файлах *.chr.

Приведем примеры программ, реализующих типовые графические построения.

1. Реализация процедуры, выводящей строку текста в центр прямоугольного окна на экране.

procedure centerstring

(x1,y1,x2,y2,color :integer; str: string);

var cx,cy:integer;

begin

setcolor (color); {Устанавливаем цвет}

rectangle (x1,y1,x2,y2); {Рамка}

rectangle (x1+2,y1+2,x2-2,y2-2);

cx:=(x1+ x2) div 2; {Координаты}

cy:=(y1+ y2) div 2; {центра}

settextJustify (centertext,centertext);

{Выравнивание текста по центру}

outtextxy (cx,cy,str); {Вывод строки}

end;

...

{ Обращение к данной процедуре: }

centerstring (100, 100, 200, 200, yELLOW,

'Hello!');

2. В следующем примере мы нарисуем на экране как "линейный" объект (домик с переменным числом окон и этажей), так и "радиальный" (солнце с лучами), для которого нужен пересчет из декартовых координат в полярные. Схема, поясняющая принцип перевода из декартовых координат в полярные, приведена на рис. 25.1.





Рис. 25.1. Пересчет из декартовых координат в полярные



program SunHouse;

uses graph,crt;

var Driver, Mode: integer;

i,j,u,N,K,x2,y2:integer;

rad:real; sunx,suny:integer;



begin

{Не проверяем правильность ввода}

writeln ('Сколько этажей?'); read (N);

writeln ('Сколько окон на этаж?');

read (K);

Driver := VGA; Mode:=VGAHi;

initgraph(Driver, Mode,'');

{Домик}

setcolor (15);

rectangle (20, getmaxy-20-70*n,

20+k*50+(k+1)*20, getmaxy-20);

{Крыша}

moveto (20,getmaxy-20-70*n);

lineto(10,getmaxy-20-70*n);

lineto (20,getmaxy-40-70*n);

lineto (20+k*50+(k+1)*20,getmaxy-40-70*n);

lineto (30+k*50+(k+1)*20,getmaxy-20-70*n);

lineto (20+k*50+(k+1)*20,getmaxy-20-70*n);

{Линии между этажами}

for i:=1 To N Do

line (20, getmaxy-20-70*i,

20+k*50+(k+1)*20, getmaxy-20-70*i);

setfillstyle (solidfill, YELLOW);

{Окна на каждом этаже}

for i:=1 To N Do {Цикл по этажам}

for j:=1 To K Do begin {Цикл по окнам}

bar(20+(j-1)*70+20,getmaxy-20-(i-1)*70-

60,20+(j-1)*70+70, getmaxy-20-(i-1)*70-10);

end;

sunx:=getmaxx-50; suny:=50;

{Центр солнца - координаты на экране}

FillEllipse (sunx, suny, 30, 30);

{Рисуем контур солнца}

setcolor (YELLOW);

{Рисуем лучи}

u:=0;

while u<=360 Do begin

{угол u меняем от 0 до 360 градусов}

rad:=u*pi/180;

{перевод в радианы для функций sin,cos }

x2:=round(sunx+50*cos(rad));

y2:=round(suny+50*sin(rad));

{перевод из полярных координат в декартовы}

line (sunx,suny,x2,y2);

u:=u+12; {шаг по углу=12 градусов}

end;

repeat until keypressed;

closegraph;

end.



3. Этот пример реализует программу построения графика функции f(x), заданной отдельной подпрограммой, в границах [a, b] изменения аргумента x.

Схема пересчета значений (x, f(x)) при в экранные координаты приведена на рис. 25.2. Пересчет выполняется в 2 этапа.

Узнав с помощью процедур getmaxx, getmaxy размеры графического экрана и определив значение xstep -- шаг по x, соответствующий одному пикселу на экране, мы сможем обеспечить масштабирование графика по оси X. Для масштабирования по оси Y на первом этапе пересчета требуется также определить максимальное и минимальное значения f(x) на интервале [a, b] при изменении x с шагом xstep.

Второй этап связан с непосредственным пересчетом значений (x, f(x)) в экранные координаты (cx, cy). Для решения этой задачи воспользуемся формулой, согласно которой значение x, принадлежащее интервалу [a, b], можно линейно преобразовать в значение y, принадлежащее интервалу [c, d]: . Эта формула позволит получить коэффициенты преобразования величин (x, f(x)) к экранным координатам. Дополнительно придется учесть то, что экранная ось Y проведена сверху вниз.





Рис. 25.2. Пересчет из декартовых координат в экранные



program graphOfFun;

uses graph,crt;



function f(x:real):real;

{ Функция, график которой строим }

begin

f:=sin(x)+cos(x);

end;



function getreal(s:string):real;

var f:real; {Ввод числа с контролем ошибок}

begin

repeat

write (s);

{$I-}readln(f);{$I+}

if IoResult=0 then break

else writeln

('Ошибка! Введено не число');

until false;

getreal:=f;

end;



procedure Init;

{Инициализация графического режима }

{VGA 640*480 пикселов, 16 цветов}

var driver,mode,error:integer;

begin

driver:=VGA; mode:=VGAHi;

initgraph(driver,mode,'');

error:=graphresult;

if error<>0 then begin

{Не ноль означает ошибку!}

writeln;

write ('Не могу инициализировать ',

'графику! Ошибка ',grapherrormsg(error));

halt(1)

end;

end;



var a,b: real; { Границы изменения x }

xmax,ymax: integer; { Размеры графического

экрана по длине и высоте }

xstep:real; { Шаг по x }

x,fx:real;

fmax,fmin:real;

cx,cy:integer; { Экранные координаты }

oldx,oldy:integer;{В этих переменных будем

запоминать координаты последней точки,

чтобы соединить ее с текущей }

xcoef,ycoef:real; {Коэффициенты пересчета к

экранным координатам }

ss:string;

begin

clrscr;

repeat

a:=getreal ('Левая граница по x=');

b:=getreal ('Правая граница по x=');

if a>b then write('Ошибка!Левая граница',

' должна быть меньше правой');

until afmax then fmax:=fx

else if fxa then line (oldx,oldy,cx,cy);

{ Соединяем две последние точки }

oldx:=cx; oldy:=cy;

{ Запоминаем текущую точку }

x:=x+xstep;

end;

repeat until keyPressed;

closegraph;

end.

Недостаток этой программы -- отсутствие пропорционального масштабирования по осям x и y. Подумайте, как ее можно улучшить. Листинг 12 из Приложения 4 представляет более объемную графическую программу, реализующую несложную компьютерную игру. Функция Draw этого листинга может также служить примером обработки 16-цветного изображения в формате BMP из программы на Паскале.

Решение задач, связанных с выводом графики на экран, часто требует сохранения участка экранного изображения в оперативной памяти с последующим восстановлением прежней картинки. Для решения этой проблемы в библиотеке graph предусмотрен набор соответствующих функций.

В первую очередь требуется оценить объем памяти, требуемый для сохранения участка экрана. Стандартная функция библиотеки graph, имеющая вид imagesize (x1,y1,x2,y2:integer):word, где x1, y1 -- экранные координаты верхнего левого, а x2, y2 -- правого нижнего угла, возвращает число байт памяти, необходимых для сохранения заданной прямоугольной области. Эта функция может определить объем памяти до 64 Кб включительно, так как тип возвращаемого значения -- беззнаковое целое типа word. Если количество требуемой памяти больше либо равно 64 Кб, возвращается значение ошибки -11 (grError). Разумеется, вызов функции предполагает, что монитор находится в графическом режиме.

После того, как требуемое количество байт определено, программа должна позаботиться о выделении участка оперативной памяти, предназначенного для сохранения изображения. Это легко сделать, используя системную процедуру getmem (var p:pointer; size:word), где объем памяти size ранее определен функцией imagesize, а переменная p представляет собой указатель. Ранее незнакомый нам тип данных "указатель" служит для косвенного вызова одних переменных через другие. Фактически, переменная-указатель хранит адрес другой типизированной переменной и может обратиться к ней, используя синтаксис p^, где p -- имя указателя. Применение указателей позволяет создавать динамические переменные, способные в разные моменты времени адресовать различные участки оперативной памяти, в которых хранятся данные. Самый большой блок памяти, который может выделить getmem, также равен 64 Кб. Освободить ранее занятую память можно процедурой Freemem (var p:pointer; size:word).

Наконец, третий шаг -- сохранить участок экрана, используя только что сформированный в оперативной памяти буфер. Для этой цели достаточно использовать процедуру Getimage (x1,y1,x2,y2:integer; var p). Здесь параметры x1,y1,x2,y2 имеют тот же смысл, что для функции imagesize, а нетипизированный параметр-указатель p получен процедурой getmem.

Теперь требуемый участок экрана сохранен в памяти и может быть занят новым изображением. После того, как изображение выполнило свои функции и нужно восстановить прежний фрагмент экрана, достаточно вызвать процедуру putimage (x,y:integer; var p; mode:word), где x,y -- экранные координаты левого верхнего угла восстанавливаемой области, p -- указатель на сохраненную память, а переменная mode определяет, какая двоичная операция будет использована при выводе изображения на экран. Для неизмененного восстановления изображения следует передавать в качестве mode значение NormalPut, другие возможные значения параметра -- copyPut, XORPut, ORPut, ANDput и NOTPut. Все описанные функции использованы в листинге, приведенном ниже. Его изучение поможет вам в написании аналогичных программ, поддерживающих движение по экрану графических объектов.

uses graph,crt;

var Gd, Gm : integer;

P : pointer;

size : word;

x,y,width,height: integer;

ch:char;

changed:boolean;

begin

{Инициализация графики}

Gd:=VGA; Gm:=VGAHi;

initgraph(Gd, Gm, '');

if graphresult <> grOk then halt(1);

{Отрисовка фона}

setfillstyle(xHatchFill, CYAN);

bar(0, 0, getmaxx, getmaxy);

{Параметры активного окна}

x:=getmaxx div 2;

y:=getmaxy div 2;

width:=40;

height:=30;

{Выделение памяти для сохранения

фона под окном}

size:=imagesize(x,y,x+wic-m1,y+heighg-1);

getmem(P, size);

getimage(x, y, x+wic-m1, y+heighg-1, P^);

{Первая отрисовка активного окна}

setfillstyle(solidfill, RED);

bar (x,y,x+wic-m1,y+heighg-1);

{Признак изменения положения окна}

changed:=false;

repeat {Цикл движения объекта}

ch:= readkey; {Читаем код клавиши}

if ch=#0 then begin

{Если это расширенный код...}

ch:= readkey; {то читаем второй байт}

case ch of

{Реагируем только на 4 клавиши:}

#72: if y>0 then changed:=true;

{стрелка вверх}

#80: if y+height0 then changed:=true;

{стрелка влево}

#77: if y+width/dosbox.sourceforge.net[/url] и установив ее, мы можем запускать приложения DOS в любом видеорежиме с поддержкой (эмуляцией) многочисленных устаревших программных и аппаратных решений.

Желательно также установить оболочку эмулятора, позволяющую создавать для DOS-приложений настраиваемые ярлыки. Оболочка DOSShell доступна по адресу http://www.loonies.narod.ru/dosshell.htm, а узнать об эмуляторах DOS больше Вы можете по адресам http://ru.wikipedia.org/wiki/DOSBox и http://gh.gameslife.ru/text/dosbox.htm.

Таблицы ASCII-кодов символов для операционных систем DOS и Windows

Понедельник, 05 Октября 2009 г. 23:32 + в цитатник
Чтобы понять, как хранится информация в ЭВМ, нам придется вспомнить ряд терминов.

Минимальная единица измерения информации -- один бит. Бит -- это двоичный разряд со значением "0" или "1". Очевидно, почему разработчики первых ЭВМ остановились на двоичной системе счисления. Числа в этой системе легче всего представить физически -- допустим, нулю соответствует состояние "не намагничено" участка магнитной ленты, а единице -- "намагничено", или нулю -- состояние "нет сигнала", а единице -- "есть сигнал" в некоторой линии связи.

Вся информация в компьютере хранится в числовой форме и двоичной системе счисления. Поскольку с помощью одного бита можно представить всего 2 различных значения, минимальной передаваемой или адресуемой единицей информации является байт, представляющий собой совокупность 8 бит. Более крупными единицами измерения данных являются килобайт (Кб) =1024 (210) байта, мегабайт (Мб) =1024 килобайта и гигабайт (Гб) =1024 мегабайта. Для ориентировки можно сказать, что если на странице текста помещается в среднем 2500 знаков, то 1 Мб -- это примерно 400 страниц, а 1 Гб -- 400 тысяч страниц.

Легко понять, сколько различных значений может быть представлено с помощью N бит -- это число равно 2N. Таким образом, в один байт "уместится" 28 = 256 различных значений.

Для обработки на компьютере вся нечисловая информация должна быть преобразована в числовую форму. Так, для компьютерной обработки текста каждая буква при вводе кодируется определенным числом, а при выводе на внешние устройства, такие как монитор или принтер, по кодам символов строятся соответствующие изображения букв. Соответствие между набором символом и кодирующими их числами называется кодировкой символов. Как правило, код символа хранится в одном байте, поэтому коды символов могут принимать значения от 0 до 255. Такие кодировки называются однобайтовыми. Основной символьный набор компьютера -- это стандартная для IBM-совместимых машин однобайтовая кодировка ANSI, называемая также ASCII-кодом (читается "аски-код").

В двухбайтовой кодировке Unicode (Юникод), предлагаемой в настоящее время в качестве общемирового стандарта, символ кодируется двумя байтами, таким образом, коды символов могут принимать значения от 0 до 65535=216 различных символов. В этой кодировке имеются коды для всех букв алфавитов множества языков, математических, декоративных символов и т. д.

На рис. П1 представлены две основные русскоязычные кодировки, известные как DOS-866 и Windows-1251. С первой работает среда Турбо-Паскаль и все программы русифицированных версий DOS, со второй -- все приложения русифицированных версий Windows. Чтобы узнать код символа, достаточно к числу десятков из первого столбца приписать число единиц из первой строки. Так, код буквы "Z" в обеих кодировках равен 90. Символы с кодами меньше 32 -- непечатаемые, это такие символы, как перевод строки, возврат каретки, табуляция, поэтому они не вошли в таблицу. Код пробела равен 32. Обратите внимание, что первые половины кодовых таблиц (символы с кодами меньше 128) совпадают как в этих двух кодировках, так и во всех остальных.

Основные директивы компилятора Паскаля

Понедельник, 05 Октября 2009 г. 23:29 + в цитатник
{$A+} -- включить/выключить выравнивание по словам.

{$B+} -- включить/выключить полное вычисление булевых выражений.

{$С MOVEABLE DEMANDLOAD DISCARDABLE} --управление сегментом кода (только режимы Windows и Protected):

· MOVEABLE -- система может изменить положение сегмента кода в памяти;

· FIXED -- система не может изменить положение сегмента кода в памяти;

· PRELOAD -- сегмент кода загружается с началом исполнения программы;

· DEMANDLOAD -- сегмент кода загружается только при обращении;

· PERMANENT -- сегмент кода остается в памяти после загрузки;

· DISCARDABLE -- сегмент кода может быть выгружен после обращения.

{$D+} -- включить/выключить отладочную информацию.

{$E+} -- включить/выключить эмуляцию сопроцессора вещественных чисел.

{$F+} -- включить/выключить FAR-вызовы по умолчанию.

{$G Имя_модуля1, Имя_модуля2, ...} -- включить в проект указанные модули Unit (только режимы Windows и Protected).

{$G+} -- включить/выключить генерацию кода процессора 80286.

{$I Имя_файла} -- включить исходный текст файла *.pas в программу.

{$I+} -- включить/выключить контроль операций ввода-вывода.

{$K+} -- включить/выключить оптимизацию вызовов подпрограмм (только Windows).

{$L Имя_файла} -- включить файл *.obj в программу на этапе сборки.

{$L+} -- включить/выключить генерацию MAP-файла.

{$M Стек, Хип-минимум, Хип-максимум} -- указать размеры стека (1024-65520) и хипа (0-655360) для программы в байтах.

{$N+} -- включить/выключить поддержку сопроцессора 80x87.

{$O+} -- включить/выключить поддержку оверлеев.

{$O Имя_модуля} -- подключить оверлейный модуль (unit).

{$P+} -- если директива включена, строки "открыты" ("закрыть" для совместимости со старыми версиями).

{$Q+} -- включить/выключить контроль переполнения для арифметических операций.

{$R+} -- включить/выключить контроль переполнения для порядковых величин.

{$R Имя_файла} -- подключить файл ресурсов *.res (только Windows и Protected).

{$S Размер} -- указать размер сегмента кода (только Windows и Protected).

{$S+} -- включить/выключить проверку переполнения стека.

{$T+} --включить/выключить контроль типов указателей.

{$V+} -- включить/выключить строгий контроль длины строк.

{$W+} -- если режим включен, генерируются начальный и завершающий код для far-функций и процедур.

{$X+} -- включить/выключить расширенный синтаксис.

{$Y+} -- включить/выключить генерацию таблицы перекрестных ссылок.

Основные сообщения об ошибках Паскаля

Понедельник, 05 Октября 2009 г. 23:28 + в цитатник
Сообщения компилятора о синтаксических ошибках:

1 -- выход за границы памяти;

2 -- не указан идентификатор;

3 -- неизвестный идентификатор;

4 -- повторный идентификатор;

5 -- синтаксическая ошибка;

6 -- ошибка в вещественной константе;

7 -- ошибка в целочисленной константе;

8 -- строковая константа превышает размеры строки;

9 -- слишком много вложенных файлов;

10 -- неправильный конец файла;

11 -- строка слишком длинная;

12 -- требуется идентификатор типа;

13 -- слишком много открытых файлов;

14 -- неверное имя файла;

15 -- файл не найден;

16 -- диск заполнен;

17 -- неправильная директива компилятора;

18 -- слишком много файлов;

19 -- неопределенный тип в определении ссылки;

20 -- нужен идентификатор переменной;

21 -- ошибка в определении типа;

22 -- слишком большая структура;

23 -- базовый тип множества нарушает границы;

24 - компонентами файла не могут быть файлы или объекты;

25 -- неверная длина строки;

26 -- несоответствие типов;

27 -- неправильный базовый тип отрезка типа;

28 -- нижняя граница больше верхней;

29 -- нужен порядковый тип;

30 -- нужна целая константа;

31 -- нужна константа;

32 -- нужна целая или действительная константа;

33 -- нужен идентификатор типа;

34 -- неправильный тип результата функции;

35 -- нужен идентификатор метки;

36 -- нужен begin;

37 -- нужен end;

38 -- нужно выражение типа integer;

39 -- нужно выражение перечисляемого типа;

40 -- нужно выражение типа boolean;

41 -- типы операндов не соответствуют оператору;

42 -- ошибка в выражении;

43 -- неверное присваивание;

44 -- нужен идентификатор поля;

45 -- объектный файл слишком большой (больше 64 Кб);

46 -- неопределенная внешняя процедура;

47 -- неправильная запись объектного файла;

48 -- сегмент кода слишком большой (больше 65520 байт);

49 -- сегмент данный слишком велик;

50 -- нужен оператор do;

51 -- неверное определение public;

52 -- неправильное определение extrn;

53 -- слишком много определений типа extrn (больше 256);

54 -- требуется of;

55 -- требуется интерфейсная секция;

56 -- недействительная перемещаемая ссылка;

57 -- требуется then;

58 -- требуется to или downto;

59 -- неопределенное опережающее описание;

60 -- слишком много процедур (больше 512 в одном модуле);

61 -- неверное преобразование типа;

62 -- деление на нуль;

63 -- неверный файловый тип;

64 - невозможно прочитать или записать переменные данного типа;

65 - требуется использование переменной-указателя;

66 -- нужна строковая переменная;

67 -- нужно выражение строкового типа;

68 -- программный модуль не найден;

69 -- несоответствие времен программных модулей;

70 -- несоответствие версий программных модулей;

71 -- повторное имя программного модуля;

72 -- ошибка формата файла программного модуля;

73 -- требуется секция реализации;

74 -- типы константы и тип выражения оператора case не соответствуют друг другу;

75 -- нужна переменная типа запись;

76 -- константа нарушает границы;

77 -- нужна файловая переменная;

78 -- нужно выражение типа указатель;

79 -- нужно выражение типа real или integer;

80 -- метка не находится внутри текущего блока;

81 -- метка уже определена;

82 -- неопределенная метка в предыдущем разделе операторов;

83 -- недействительный аргумент оператора @;

84 -- требуется ключевое слово unit;

85 -- требуется указать ";";

86 -- требуется указать ":";

87 -- требуется указать ",";

88 -- требуется указать "(";

89 -- требуется указать ")";

90 -- требуется указать "=";

91 -- требуется указать ":=";

92 -- требуется "[" или "(.";

93 -- требуется "]" или ".)";

94 -- требуется ".";

95 -- требуется "..";

96 -- слишком много переменных;

97 -- неправильная переменная цикла оператора for. Переменная должна быть перечислимого типа;

98 -- нужна переменная целого типа;

99 -- здесь не допускаются файлы;

100 -- несоответствие длины строковой переменной или константы;

101 -- неверный порядок полей;

102 -- нужна константа строкового типа;

103 -- нужна переменная типа integer или real;

104 -- нужна переменная перечисляемого типа;

105 -- ошибка в операторе inline;

106 -- предшествующее выражение должно иметь символьный тип;

107 -- слишком много перемещаемых элементов;

108 -- недостаточно памяти для выполнения программы;

109 -- нет возможности найти файл .EXE;

110 -- модуль выполнять нельзя;

111 -- компиляция прервана с помощью клавиш Ctrl+Break;

112 -- константа оператора case находится вне границ;

113 -- ошибка в операторе. Данный символ не может быть первым символом в операторе;

114 -- невозможно вызвать процедуру прерывания;

115 -- для компиляции необходимо наличие сопроцессора 8087;

116 -- для компиляции необходим режим 8087;

117 -- адрес назначения не найден;

118 -- в такой ситуации включаемые файлы не допускаются;

119 -- ошибка формата файла .TPU;

120 -- требуется NIL;

121 -- неверный квалификатор переменной;

122 -- недействительная ссылка на переменную;

123 -- слишком много символов (больше 64 Кб);

124 -- слишком большой раздел операторов (больше 64 Кб);

125 -- в модуле нет отладочной информации;

126 -- параметры файлового типа должны быть параметрами var;

127 -- слишком много условных символов;

128 -- пропущена условная директива;

129 -- пропущена директива endif;

130 -- ошибка в начальных условных определениях;

131 -- заголовок не соответствует предыдущему определению;

132 -- критическая ошибка диска;

133 -- нельзя вычислить данное выражение;

134 -- некорректное завершение выражения;

135 -- неверный спецификатор формата;

136 -- недопустимая косвенная ссылка;

137 -- здесь не допускается использование структурной переменной;

138 -- нельзя вычислить без блока system;

139 -- доступ к данному символу отсутствует;

140 -- недопустимая операция с плавающей запятой;

141 -- нельзя выполнить компиляцию оверлеев в память;

142 -- должна использоваться переменная-процедура или функция;

143 -- недопустимая ссылка на процедуру или функцию;

144 -- этот модуль не может использоваться в качестве оверлейного.

Сообщения об ошибках времени исполнения программы:;

1 -- не найден файл;

3 -- не найден путь;

4 -- слишком много открытых файлов;

5 -- отказано в доступе к файлу;

6 -- недоступный файловый канал;

12 -- недействительный код доступа к файлам;

15 -- недопустимый номер дисководов;

16 -- нельзя удалить текущий каталог;

17 -- нельзя при именовании указывать разные дисководы;

100 -- ошибка чтения диска;

101 -- ошибка записи на диск;

102 -- файлу не присвоено имя;

103 -- файл не открыт;

104 -- файл не открыт для ввода;

105 -- файл не открыт для вывода;

106 -- неверный числовой формат;

150 -- диск защищен от записи;

151 -- неизвестный модуль;

152 -- дисковод находится в состоянии "не готов";

153 -- неопознанная команда;

154 -- в исходных данных;

155 -- при запросе к диску неверная длина структуры;

156 -- ошибка при операции установки головок на диске;

157 -- неизвестный тип носителя;

158 -- сектор не найден;

159 -- кончилась бумага на устройстве печати;

160 -- ошибка при записи на устройство;

161 -- ошибка при чтении с устройства;

162 -- сбой аппаратуры;

200 -- деление на нуль;

201 -- ошибка при проверке границ;

202 -- переполнение стека;

203 -- переполнение динамически распределяемой области памяти;

204 -- недействительная операция ссылки;

205 -- переполнение операции с плавающей запятой;

206 -- исчезновение порядка при операции плавающей запятой;

207 -- недопустимая операция с плавающей запятой;

208 -- не установлена подсистема управления оверлеями;

209 -- ошибка чтения оверлейного файла.

Дополнительные листинги программ

Понедельник, 05 Октября 2009 г. 23:27 + в цитатник
Pers.narod.ru. Обучение. Учебник по Паскалю. Приложение 4

Приложение 4. Дополнительные листинги программ



1. Решение системы линейных алгебраических уравнений Ax=b методом Гаусса.

program Slau;

uses crt;

const size=30; {максимально допустимая размерность}

type matrix=array [1..size,1..size+1]

of real;

type vector=array [1..size] of real;



function GetNumber (s:string;

a,b:real):real;

{Ввод числа из интервала a,b.

Если a=b, то число любое}

var n:real;

begin

repeat

write (s);

{$I-}readln (n);{$I+}

if (IoResult<>0) then

writeln ('Введено не число!')

else if (ab)) then

writeln ('Число не в интервале от ',

a,' до ',b)

else break;

until false;

GetNumber:=n;

end;



procedure GetMatrix (n,m:integer;

var a:matrix); {ввод матрицы}

var i,j:integer; si,sj: string [3];

begin

for i:=1 to n do begin

str (i,si);

for j:=1 to m do begin

str (j,sj);

a[i,j]:=GetNumber ('a['+ si+ ','+ sj+

']=', 0,0);

end;

end;

end;



procedure GetVector (n:integer;

var a:vector); {ввод вектора}

var i:integer; si:string [3];

begin

for i:=1 to n do begin

str (i,si);

a[i]:=GetNumber ('b['+si+']=',0,0);

end;

end;



procedure PutVector (n:integer;

var a:vector); {вывод вектора}

var i:integer;

begin

writeln;

for i:=1 to n do writeln (a[i]:10:3);

end;



procedure MV_Mult (n,m:integer;

var a:matrix;var x,b:vector);

{умножение матрицы на вектор}

var i,j:integer;

begin

for i:=1 to n do begin

b[i]:=0;

for j:=1 to m do b[i]:=b[i]+a[i,j]*x[j];

end;

end;



function Gauss (n:integer; var a:matrix;

var x:vector):boolean;

{метод Гаусса решения СЛАУ}

{a - расширенная матрица системы}

const eps=1e-6; {точность расчетов}

var i,j,k:integer;

r,s:real;

begin

for k:=1 to n do begin {перестановка

для диагонального преобладания}

s:=a[k,k];

j:=k;

for i:=k+1 to n do begin

r:=a[i,k];

if abs(r)>abs(s) then begin

s:=r;

j:=i;

end;

end;

if abs(s)k then

for i:=k to n+1 do begin

r:=a[k,i];

a[k,i]:=a[j,i];

a[j,i]:=r;

end; {прямой ход метода}

for j:=k+1 to n+1 do a[k,j]:=a[k,j]/s;

for i:=k+1 to n do begin

r:=a[i,k];

for j:=k+1 to n+1 do

a[i,j]:=a[i,j]-a[k,j]*r;

end;

end;

if abs(s)>eps then begin {обратный ход}

for i:=n downto 1 do begin

s:=a[i,n+1];

for j:=i+1 to n do s:=s-a[i,j]*x[j];

x[i]:=s;

end;

Gauss:=true;

end

else Gauss:=false;

end;



var a,a1:matrix;

x,b,b1:vector;

n,i,j:integer;



begin

n:=trunc(GetNumber

('Введите размерность матрицы: ',2,size));

GetMatrix (n,n,a);

writeln ('Ввод правой части:');

GetVector (n,b);

for i:=1 to n do begin

{делаем расширенную матрицу}

for j:=1 to n do a1[i,j]:=a[i,j];

a1[i,n+1]:=b[i];

end;

if Gauss (n,a1,x)=true then begin

write ('Решение:');

PutVector (n,x);

write ('Проверка:');

MV_Mult (n,n,a,x,b1);

PutVector (n,b1);

end

else write ('Решения нет');

reset (input); readln;

end.



2. Процедурно-ориентированная реализация задачи сортировки одномерного массива по возрастанию.

program sort;

const size=100;

type vector=array [1..size] of real;



procedure GetArray (var n:integer;

var a:vector);

var i:integer;

begin

repeat

writeln ('Введите размерность массива:');

{$I-}readln (n); {$I+}

if (IoResult<>0) or (n<2) or (n>size)

then writeln

('Размерность должна быть от 2 до ',size);

until (n>1) and (n1) and (n 0 then begin

Warning

('Не могу открыть файл '+filename+

'... Будет создан новый файл');

{$I-}rewrite (f);{$I+}

if IoResult <> 0 then

Error ('Не могу создать файл! '+

'Проверьте права и состояние диска');

end

else break;

until false;

end;



procedure getsize (var kol:longint;

var size:integer);

{Вернет текущее число записей kol и

размер записи в байтах size}

begin

reset (f);

size:=sizeof(student);

if filesize(f)=0 then kol:=0

else begin

seek(F, Filesize(F));

kol:=filepos (f);

end;

end;



function getname (s:string):string;

{Переводит строку в верхний регистр

c учетом кириллицы DOS}

var i,l,c:integer;

begin

l:=length(s);

for i:=1 to l do begin

c:=ord(s[i]);

if (c>=ord('а')) and (c<=ord('п'))

then c:=c-32

else if (c>=ord('р')) and (c<=ord('я'))

then c:=c-80;

s[i]:=Upcase(chr(c));

end;

getname:=s;

end;



procedure prints;

{Вспомогательная процедура печати -

печатает текущую s}

var i:integer;

begin

write (getname(s.name),': ');

for i:=1 to 4 do begin

write (s.balls[i]);

if i<4 then write (',');

end;

writeln;

end;



procedure print (n:integer); {Вывести

запись номер n (с переходом к ней)}

begin

seek (f,n-1); read (f,s); prints;

end;



procedure go (d:integer); {Перейти на d

записей по базе}

begin

writeln;

write ('Текущая запись: ');

if current=0 then writeln ('нет')

else begin

writeln (current);

print (current);

end;

current:=current+d;

if current<1 then begin

Warning ('Не могу перейти на запись '+

'с номером меньше 1');

if kol>0 then current:=1

else current:=0;

end

else if current>kol then begin

str (kol,st1);

Warning ('Не могу перейти на запись '+

'с номером больше '+st1);

current:=kol;

end

else begin

writeln ('Новая запись: ',current);

print (current);

end;

end;



procedure search;

{Поиск записи в базе по фамилии}

var i,found,p:integer;

begin

if kol<1 then

Warning ('База пуста! Искать нечего')

else begin

writeln;

write ('Введите фамилию (часть фамилии)',

' для поиска, регистр символов любой:');

reset (input);

readln (st1);

st1:=getname(st1);

seek (f,0);

found:=0;

for i:=0 to kol-1 do begin

read (f,s);

p:=pos(st1,getname(s.name));

if p>0 then begin

writeln ('Запись номер ',i+1);

prints;

found:=found+1;

if found mod 10 = 0 then

Warning ('Пауза...');

{Пауза после вывода 10 найденных}

end;

end;

if found=0 then

Warning ('Ничего не найдено...');

end;

end;



procedure add;

{Добавить запись в конец базы}

var i,b:integer;

begin

repeat

writeln;

write ('Введите фамилию студента ',

'для добавления:');

reset (input);

readln (st1);

if length(st1)<1 then begin

Warning ('Слишком короткая строка!'+

' Повторите ввод');

continue;

end

else if length(st1)>20 then begin

Warning ('Слишком длинная строка! '+

'Будет обрезана до 20 символов');

st1:=copy (st1,1,20);

end;

s.name:=st1;

break;

until false;

for i:=1 to 4 do begin

repeat

writeln; {следовало бы предусмотреть

возможность ввода не всех оценок}

write ('Введите оценку ',i,' из 4:');

{$I-}readln (b);{$I+}

if (IoResult<>0) or (b<2) or (b>5)

then begin

Warning ('Неверный ввод! Оценка - '+

'это число от 2 до 5! Повторите.');

continue;

end

else begin

s.balls[i]:=b; break;

end;

until false;

end;

seek (f,filesize(f));

write (f,s); kol:=kol+1; current:=kol;

end;



procedure delete; {Удаление текущей записи}

var f2:file of student; i:integer;

begin

if kol<1 then

Warning ('База пуста! Удалять нечего')

else begin

assign (f2,'students.tmp');

{$I-}rewrite(f2);{$I+}

if IoResult<>0 then begin

Warning ('Не могу открыть новый файл '+

'для записи!'+#13+#10+

' Операция невозможна. Проверьте '+

'права доступа и текущий диск.');

Exit;

end;

seek (f,0);

for i:=0 to kol-1 do begin

if i+1<>current then begin

{переписываем все записи, кроме текущей}

read (f,s); write (f2,s);

end;

end;

close (f); {закрываем исходную БД}

erase (f); {Удаляем исходную БД,

проверка IoResult опущена!}

rename (f2,filename); {Переименовываем f2

в имя БД}

close (f2); {Закрываем

переименованный f2}

open; {Связываем БД с прежней

файловой переменной f}

kol:=kol-1;

if current>kol then current:=kol;

end;

end;



procedure sort;

{сортировка базы по фамилии студента}

var i,j:integer;

s2:student;

begin

if kol<2 then

Warning ('В базе нет 2-х записей!'+

' Сортировать нечего')

else begin

for i:=0 to kol-2 do begin

{Обычная сортировка}

seek (f,i); {только в учебных целях -

работает неоптимально}

read (f,s);{и много обращается к диску!}

for j:=i+1 to kol-1 do begin

seek (f,j);

read (f,s2);

if getname(s.name)>getname(s2.name)

then begin

seek (f,i); write (f,s2);

seek (f,j); write (f,s);

s:=s2; {После перестановки в s уже

новая запись!}

end;

end;

end;

end;

end;



procedure edit; {редактирование записи

номер current}

var i,b:integer;

begin

if (kol<1) or (current<1) or (current>kol)

then Warning ('Неверный номер '+

'текущей записи! Не могу редактировать')

else begin

seek (f,current-1);

read (f,s);

repeat

writeln ('Запись номер ',current);

writeln ('Выберите действие:');

writeln ('1. Фамилия (',s.name,')');

for i:=1 to 4 do

writeln (i+1,'. Оценка ',i,

' (',s.balls[i],')');

writeln ('0. Завершить редактирование');

reset (input);

{$I-}readln (b);{$I+}

if (IoResult<>0) or (b<0) or (b>5) then

Warning ('Неверный ввод! Повторите')

else begin

if b=1 then begin

write ('Введите новую фамилию:');

{для простоты здесь нет}

{проверок корректности}

reset (input); readln (s.name);

end

else if b=0 then break

else begin

write ('Введите новую оценку:');

reset (input); readln (s.balls[b-1]);

end;

end;

until false;

seek (f,current-1);

{Пишем, даже если запись не менялась -}

write (f,s); {в реальных проектах

так не делают}

end;

end;



procedure menu; {Управление главным меню и

вызов процедур}

var n:integer;

begin

repeat

writeln;

writeln ('Выберите операцию:');

writeln ('1 - вперед');

writeln ('2 - назад');

writeln ('3 - поиск по фамилии');

writeln ('4 - добавить в конец');

writeln ('5 - удалить текущую');

writeln ('6 - сортировать по фамилии');

writeln ('7 - начало базы');

writeln ('8 - конец базы');

writeln ('9 - изменить текущую');

writeln ('0 - выход');

reset (input);

{$I-}read (n);{$I+}

if (IoResult<>0) or (n<0) or (n>9)

then begin

Warning ('Неверный ввод!');

continue;

end

else break;

until false;

case n of

1: go (1);

2: go (-1);

3: search;

4: add;

5: delete;

6: sort;

7: go (-(current-1));

8: go (kol-current);

9: edit;

0: out;

end;

end;



begin {Главная программа}

open;

getsize (kol,size);

str(kol,st1);

str(size,st2);

writeln;

writeln('==============================');

writeln('Учебная база данных "Студенты"');

writeln('==============================');

Warning ('Файл '+FileName+

' открыт'+#13+#10+

'Число записей='+st1+#13+#10+

'Размер записи='+st2+#13+#10);

{+#13+#10 - добавить к строке символы

возврата каретки и первода строки}

if kol=0 then current:=0

else current:=1;

repeat

menu;

until false;

end.



5. Программа содержит коды часто используемых клавиш и печатает их названия.

uses crt;

const ESC=#27; ENTER=#13; F1=#59;

F10=#68; TAB=#9; SPACE=#32;

UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77;

HOME=#71; END_=#79;

PAGE_UP=#73; PAGE_DN=#81;

var ch:char;

begin

clrscr;

repeat

ch:=Upcase(readkey);

case ch of

'A'..'z': write ('Letter');

SPACE: write ('SPACE');

ENTER: write ('ENTER');

TAB: write ('TAB');

#0: begin

ch:=readkey;

case ch of

F1: write ('F1');

F10: write ('F10');

LEFT: write ('LEFT');

RIGHT: write ('RIGHT');

UP: write ('UP');

DOWN: write ('DOWN');

HOME: write ('HOME');

END_: write ('END');

PAGE_UP: write ('PgUp');

PAGE_DN: write ('PgDn');

end;

end;

else begin

end;

end;

until ch=Esc;

end.



6.1. Программа позволяет двигать по текстовому экрану "прицел" с помощью клавиш со стрелками.

uses crt;

{$V-} {отключили строгий контроль типов}

const ESC=#27; UP=#72; DOWN=#80;

LEFT=#75; RIGHT=#77;

var ch:char;



procedure Draw (x,y:integer;mode:boolean);

{mode определяет, нарисовать или стереть}

var sprite:array [1..3] of string [3];

{"прицел", заданный массивом sprite}

i:integer;

begin

sprite[1]:='/|';

sprite[2]:='-=-';

sprite[3]:='\|/';

if mode=true then textcolor (White)

else textcolor (Black);

for i:=y to y+2 do begin

gotoxy (x,i); write (sprite[i-y+1]);

end;

gotoxy (x+1,y+1);

end;



procedure status (n:integer; s:string);

{рисует строку статуса

внизу или вверху экрана}

begin

textcolor (Black); textbackground (White);

gotoxy (1,n); write (' ':79);

gotoxy (2,n); write (s);

textcolor (White); textbackground (Black);

end;



var x,y:integer;



begin

textMode (cO80);

status (1,'Пример управления движением!');

status(25,'Стрелки-управление;ESC-выход');

x:=10; y:=10;

repeat

Draw (x,y,true);

ch:=Upcase(readkey);

case ch of

#0: begin

ch:=readkey;

Draw (x,y,false);

case ch of

LEFT: if x>1 then x:=x-1;

RIGHT: if x<77 then x:=x+1;

UP: if y>2 then y:=y-1;

DOWN: if y<22 then y:=y+1;

end;

end;

end;

until ch=ESC;

clrscr;

end.



6.2. Эта версия программы 6.1 позволяет "прицелу" продолжать движение до тех пор, пока он не натолкнется на край экрана.

uses crt;

{$V-}

const ESC=#27; UP=#72; DOWN=#80;

LEFT=#75; RIGHT=#77;

const goleft=1; GoRight=2; goup=3;

godown=4; gostop=0;

{возможные направления движения}

const myDelay=1000; {задержка для Delay}

var ch:char; LastDir:integer;

{последнее направление движения}



procedure Draw (x,y:integer;mode:boolean);

var sprite:array [1..3] of string [3];

i:integer;

begin

sprite[1]:='/|';

sprite[2]:='-=-';

sprite[3]:='\|/';

if mode then textcolor (White)

else textcolor (Black);

for i:=y to y+2 do begin

gotoxy (x,i);

write (sprite[i-y+1]);

end;

gotoxy (x+1,y+1);

end;



procedure status (n:integer; s:string);

begin

textcolor (Black); textbackground (White);

gotoxy (1,n); write (' ':79);

gotoxy (2,n); write (s);

textcolor (White); textbackground (Black);

end;



var x,y:integer;



begin

clrscr;

status(1,'Управление движением-2');

status(25,'Стрелки-управление;ESC-выход');

x:=10; y:=10; LastDir:=goleft;

repeat {бесконечный цикл работы программы}

repeat {цикл до нажатия клавиши}

Draw (x,y,true); Delay (myDelay);

Draw (x,y,false);

case LastDir of

goLeft:

if x>1 then Dec(x)

else begin

x:=1; LastDir:=gostop;

end;

GoRight:

if x<77 then inc(x)

else begin

x:=77; LastDir:=gostop;

end;

goUp:

if y>2 then Dec(y)

else begin

y:=2; LastDir:=gostop;

end;

goDown:

if y<22 then inc(y)

else begin

y:=22; LastDir:=gostop;

end;

end;

until keyPressed;

{обработка нажатия клавиши}

ch:=Upcase(readkey);

case ch of

#0: begin

ch:=readkey;

case ch of

LEFT: LastDir:=goLeft;

RIGHT: LastDir:=GoRight;

UP: LastDir:=goUp;

DOWN: LastDir:=goDown;

end;

end;

ESC: halt;

end;

until false;

end.



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

uses crt; { Глобальные данные: }

const maxmenu=2; {количество меню}

maxpoints=3; {макс. количество пунктов}

var x1,x2,y: array [1..maxmenu] of integer;

{x1,x2- начало и конец каждого меню,

y- строка начала каждого меню}

kolpoints, points: array [1..maxmenu] of

integer;{Кол-во пунктов и текущие пункты }

text: array [1..maxmenu,1..maxpoints]

of string[12]; { Названия пунктов }

txtcolor, textback, cursorback:integer;

{ Цвета текста, фона, курсора}

mainhelp:string[80]; { Строка помощи }



procedure DrawMain (s:string); {Очищает

экран, рисует строку главного меню s }

begin Window (1,1,80,25);

textcolor (txtcolor);

textbackground (textback);

clrscr; gotoxy (1,1); write (s);

end;



procedure DrawHelp (s:string);

{ Выводит подсказку s }

var i:integer; begin

textcolor (txtcolor);

textbackground (textback); gotoxy (1,25);

for i:=1 to 79 do write (' ');

gotoxy (1,25); write (s);

end;



procedure doubleFrame (x1,y1,x2,y2:integer;

Header: string);

{ Процедура рисует двойной рамкой окно }

var i,j: integer;

begin gotoxy (x1,y1);

write ('╔');

for i:=x1+1 to x2-1 do write('═');

write ('╗');

for i:=y1+1 to y2-1 do begin

gotoxy (x1,i); write('║');

for j:=x1+1 to x2-1 do write (' ');

write('║');

end;

gotoxy (x1,y2); write('╚');

for i:=x1+1 to x2-1 do write('═');

write('╝');

gotoxy (x1+(x2-x1Length(Header))

div 2,y1);

write (Header); {Выводим заголовок}

gotoxy (x1+1,y1+1);

end;



procedure clearFrame (x1,y1,x2,y2:integer);

var i,j:integer;

begin textbackground (textback);

for i:=y1 to y2 do begin

gotoxy (x1,i);

for j:=x1 to x2 do write (' ');

end;

end;



procedure cursor (Menu,Point: integer;

Action: boolean);{ Подсвечивает (если

Action=true) или гасит п. Point меню Menu}

begin textcolor (Txtcolor);

if Action=true then

textbackground (cursorBack)

else textbackground (textBack);

gotoxy (x1[Menu]+1,y[Menu]+Point);

write (text[Menu][Point]);

end;



procedure DrawMenu (Menu:integer;

Action: boolean);{Рисует меню с номером

Menu, если Action=true, иначе стирает }

var i:integer;

begin

if Action=true then textcolor (Txtcolor)

else textcolor (textBack);

textbackground (textBack);

doubleFrame (x1[Menu], y[Menu], x2[Menu],

y[Menu]+1+KolPoints[Menu],'');

for i:=1 to KolPoints[Menu] do begin

gotoxy (x1[Menu]+1, y[Menu]+i);

writeln (text[Menu][i]);

end;

end;



{Часть, определяемая пользователем}



procedure Init; { Установка глобальных

данных и начальная отрисовка }

begin

txtcolor:=yELLOW; textback:=BLUE;

cursorback:=LIGHTcyAN;

kolpoints[1]:=2; kolpoints[2]:=1;

{пунктов в каждом меню}

points[1]:=1; points[2]:=1;

{выбран по умолчанию в каждом меню}

x1[1]:=1; x2[1]:=9; y[1]:=2;

text[1,1]:='Запуск'; text[1,2]:='Выход ';

x1[2]:=9; x2[2]:=22; y[2]:=2;

text[2,1]:='О программе';

DrawMain ('Файл Справка');

MainHelp:='ESC - Выход из программы '+

'ENTER - выбор пункта меню '+

'Стрелки - перемещение';

DrawHelp(MainHelp);

end;



procedure Work; { Рабочая процедура }

var i,kol:integer; ch:char;

begin

DrawHelp('Идет расчет...');

{ Строка статуса }

textcolor (LIGHTGRAY);

textbackground (BLACK);

{ Выбираем цвета для работы в окне }

doubleFrame (2,2,78,24,' Расчет ');

Window (3,3,77,23);

{Секция действий, выполняемых программой}

writeln;

write ('Введите число шагов: ');

{$I-}read (kol);{$I+}

if IoResult<>0 then writeln

('Ошибка! Вы ввели не число')

else if kol>0 then begin

for i:=1 to kol do

writeln ('Выполняется шаг ',i);

writeln ('Все сделано!');

end

else writeln ('Ошибка! Число больше 0');

{Восстановление окна и выход}

Window (1,1,80,25);

DrawHelp('Нажмите любую клавишу...');

ch:=readkey;

clearFrame (2,2,78,24); { Стираем окно }

end;



procedure Out; { Очистка экрана и выход}

begin

textcolor (LIGHTGRAY);

textbackground (BLACK); clrscr; halt(0);

end;



procedure Help; {Окно с информацией}

var ch:char;

begin

textcolor (Txtcolor);

textbackground (textback);

doubleFrame (24,10,56,13,' О программе ');

DrawHelp ('Нажмите клавишу...');

gotoxy (25,11);

writeln(' Демонстрация простейшего меню');

gotoxy (25,12);

write ( ' Новосибирск, НГАСУ');

ch:=readkey;

clearFrame (24,10,58,13);

end;



procedure command (Menu,Point:integer);

{Вызывает процедуры после выбора в меню }

begin

if Menu=1 then begin

if Point=1 then Work

else if Point=2 then Out;

end

else begin

if Point=1 then Help;

end;

end;

{Конец части пользователя }



procedure MainMenu (Point,

HorMenu:integer); { Поддерживает систему

одноуровневых меню }

var ch: char; funckey:boolean;

begin

Points[HorMenu]:=Point;

DrawMenu (HorMenu,true);

repeat

cursor (HorMenu,Points[HorMenu],true);

ch:=readkey;

cursor (HorMenu,Points[HorMenu],false);

if ch=#0 then begin

funckey:=true; ch:=readkey;

end

else funckey:=false;

if funckey=true then begin

ch:=Upcase (ch);

if ch=#75 then begin { Стрелка влево }

DrawMenu (HorMenu,false);

HorMenu:=HorMenu-1;

if (HorMenu<1) then HorMenu:=maxMenu;

DrawMenu (HorMenu,true);

end

else if ch=#77 then begin

{ Стрелка вправо }

DrawMenu (HorMenu,false);

HorMenu:=HorMenu+1;

if (HorMenu>maxMenu) then HorMenu:=1;

DrawMenu (HorMenu,true);

end

else if ch=#72 then begin

{ Стрелка вверх }

Points[HorMenu]:=Points[HorMenu]-1;

if Points[HorMenu]<1 then

Points[HorMenu]:=Kolpoints[HorMenu];

end

else if ch=#80 then begin

{ Стрелка вниз }

Points[HorMenu]:=Points[HorMenu]+1;

if (Points[HorMenu]>KolPoints[HorMenu])

then Points[HorMenu]:=1;

end;

end

else if ch=#13 then begin

{ Клавиша ENTER }

DrawMenu (HorMenu,false);

command (HorMenu,Points[HorMenu]);

DrawMenu (HorMenu,true);

DrawHelp (MainHelp);

end;

until (ch=#27) and (funckey=false);

{ Пока не нажата клавиша ESC }

end;

{ Основная программа }

begin

Init;

MainMenu (1,1);

Out;

end.



8. Простейший "генератор" программы на Паскале. Из входного файла, содержащего текст, генерируется программа для листания этого текста.

program str2Pas;

uses crt; label 10,20;

var ch:char;str:string;

I,J,Len,count:word; InFile,OutFile:text;



procedure Error (ErNum:char);

begin

case ErNum of

#1: writeln

('Запускайте с 2 параметрами -',#13,#10,

'именами входного и выходного файла.',

#13,#10,

'Во входном файле содержится текст',

#13,#10,

'в обычном ASCII-формате,',#13,#10,

'в выходном будет программа на Паскале');

#2:

writeln

(' Не могу открыть входной файл!');

#3:

writeln

(' Не могу открыть выходной файл!');

else writeln (' Неизвестная ошибка!');

end;

halt;

end;



begin

if Paramcount<>2 then Error (#1);

assign (InFile,Paramstr(1));

reset (InFile);

if (IoResult<>0) then Error (#2);

assign (OutFile,Paramstr(2));

rewrite (OutFile);

if (IoResult<>0) then Error (#3);

{ Вписать заголовок программы }

writeln (OutFile,'uses crt;');

write (OutFile,'const colstr=');

{ Узнать число строк текста }

count:=0;

while not Eof (InFile) do begin

readLn (InFile,str);

count:=count+1;

end;

reset (InFile);

writeln (OutFile,count,';');

{ Следующий сегмент программы: }

writeln (OutFile,'var ch:char;');

writeln (OutFile,' List:boolean;');

writeln (OutFile,

' I,start,endstr:word;');

writeln (OutFile,

' ptext:array [1..colstr] of string;');

writeln (OutFile,'begin');

{ Строки листаемого текста: }

for I:=1 to count do begin

Len:=0;

repeat

if (Eof (InFile)=true) then goto 10;

read (InFile,ch);

if ch=#39 then begin

Len:=Len+1; str[Len]:=#39;

Len:=Len+1; str[Len]:=#39;

end

else if ch=#13 then begin

read (InFile,ch);

if (ch=#10) then goto 10

else goto 20;

end

else begin

20:

Len:=Len+1; str[Len]:=ch;

end;

until false;

10:

write (OutFile,' ptext[',I,']:=''');

for J:=1 to Len do

write (OutFile,str[J]);

writeln (OutFile,''';');

end;

{ Сегмент программы }

writeln (OutFile,' textcolor (YELLOW);');

writeln (OutFile,

' textbackground (Blue);');

writeln (OutFile,

' List:=true; start:=1;');

{ Последняя строка на экране: }

if (count>25) then

writeln (OutFile,' endstr:=25;')

else writeln (OutFile,' endstr:=colstr;');

writeln (OutFile,' repeat');

writeln (OutFile,

' if (List=true) then begin');

writeln (OutFile,' clrscr;');

writeln (OutFile,

' for I:=start to endstr-1 do ',

'write (ptext[I],#13,#10);');

writeln (OutFile,

' write (ptext[endstr]);');

writeln (OutFile,' List:=false;');

writeln (OutFile,' end;');

writeln (OutFile,' ch:=readkey;');

writeln (OutFile,

' if ch= #0 then begin');

writeln (OutFile,' ch:=readkey;');

writeln (OutFile,' case ch of');

writeln (OutFile,' #72: begin');

writeln (OutFile,

' if start>1 then begin');

writeln (OutFile,' start:=start-1;');

writeln (OutFile,

' endstr:=endstr-1;');

writeln (OutFile,' List:=true;');

writeln (OutFile,' end;');

writeln (OutFile,' end;');

writeln (OutFile,' #80: begin');

writeln (OutFile,

' if endstr25) then begin

writeln (OutFile,' #73: begin');

writeln (OutFile,

' if start>1 then begin');

writeln (OutFile,

' start:=1; endstr:=25;');

writeln (OutFile,' List:=true;');

writeln (OutFile,' end;');

writeln (OutFile,' end;');

writeln (OutFile,' #81: begin');

writeln (OutFile,

' if endstrrows

(число строк) или m<0 или m>cols (число

столбцов), прервет работу. }

var s:string;

begin

{$I-}read (f,n);{$I+}

if (IoResult<>0) or (n<0) or (n>rows)

then begin

str (rows,s);

Error ('Неверное число строк '+

'в файле данных!'+#13+#10+

'должно быть от 1 до '+s);

end;

{$I-}read (f,m);{$I+}

if (IoResult<>0) or (m<0) or (m>cols)

then begin

str (cols,s);

Error ('Неверное число столбцов '+

'в файле данных!'+#13+#10+

'должно быть от 1 до '+s);

end;

end;



procedure readMatrix (var f:text;

n,m:integer; var a:matrix);

{ Читает из файла f матрицу a

размерностью n*m }

var i,j:integer; er:boolean;

begin

er:=false;

for i:=1 to n do

for j:=1 to m do begin

{$I-}read (f,a[i,j]);{$I+}

if IoResult<>0 then begin

er:=true; a[i,j]:=0;

end;

end;

if er=true then begin

writeln;

writeln

('В прочитанных данных есть ошибки!');

writeln ('Неверные элементы матрицы',

' заменены нулями');

end;

end;



procedure writeMatrix (var f:text;

n,m:integer; var a:matrix);

{ Пишет в файл f матрицу a[n,m] }

var i,j:integer;

begin

for i:=1 to n do begin

for j:=1 to m do write (f,a[i,j]:11:4);

writeln (f);

end;

end;



procedure Proc1 (n,m:integer;

var a,b:matrix);

{ Матрицу a[n,m] пишет в матрицу b[n,m],

меняя знаки элементов }

var i,j:integer;

begin

for i:=1 to n do

for j:=1 to m do b[i,j]:=-a[i,j]

end;



begin

if Paramcount<1 then begin

writeln ('Имя файла для чтения:');

readLn (Name1);

end

else Name1:=Paramstr(1);

if Paramcount<2 then begin

writeln ('Имя файла для записи:');

readLn (Name2);

end

else Name2:=Paramstr(2);

assign (f1,Name1);

{$I-}reset (f1);{$I+}

if IoResult<>0 then

Error ('Не могу открыть '+Name1+

' для чтения');

assign (f2,Name2);

{$I-}rewrite (f2);{$I+}

if IoResult<>0 then

Error ('Не могу открыть '+Name2+

' для записи');

readDim (f1,n,m);

readMatrix (f1,n,m,a);

Proc1 (n,m,a,b);

writeMatrix (f2,n,m,b);

close (f1); close (f2);

end.



10. Подсчет количества дней от введенной даты до сегодняшнего дня.

program Days;

uses Dos;

const mondays: array [1..12] of integer =

(31,28,31, 30,31,30, 31,31,30, 31,30,31);

var d,d1,d2,m1,m2,y1,y2:word;



function Leapyear (year:word):boolean;

begin

if (year mod 4 =0) and (year mod 100 <>0)

or (year mod 400 =0) then Leapyear:=true

else Leapyear:=false;

end;



function correctDate

(day,mon,year:integer):boolean;

var maxday:integer;

begin

if (year<0) or (mon<1) or (mon>12) or

(day<1) then correctDate:=false

else begin

maxday:=mondays[mon];

if (Leapyear (year)=true) and (mon=2)

then maxday:=29;

if (day>maxday) then correctDate:=false

else correctDate:=true;

end;

end;



function KolDays (d1,m1,d2,m2,y:word):word;

var i,f,s:word;

begin

s:=0;

if m1=m2 then KolDays:=d2-d1

else for i:=m1 to m2 do begin

f:=mondays[i];

if (Leapyear (y)=true) and (i=2)

then f:=f+1;

if i=m1 then s:=s+(f-d1+1)

else if i=m2 then s:=s+d2

else s:=s+f;

KolDays:=s;

end;

end;



function countDays (day1, mon1, year1,

day2, mon2, year2:word):word;

var f,i:word;

begin

f:=0;

if year1=year2 then countDays:=

KolDays (day1, mon1, day2, mon2, year1)

else for i:=year1 to year2 do begin

if i=year1 then f:=

KolDays (day1, mon1, 31, 12, year1)

else if i=year2 then f:=f+

KolDays (1,1,day2,mon2,year2)-1

else f:=f+KolDays (1,1,31,12,i);

countDays:=f;

end;

end;



begin

getdate (y2,m2,d2,d);

writeln ('Год Вашего рождения?');

readln (y1);

writeln ('Месяц Вашего рождения?');

readln (m1);

writeln ('День Вашего рождения?');

readln (d1);

if correctDate (d1,m1,y1)=false then begin

writeln ('Недопустимая дата!'); halt;

end;

if (y2 grOk then begin

writeln('Ошибка инициализации графики:',

grapherrormsg(Errcode)); halt;

end;

end;



var n,x,y,x0,y0,b:integer; s1,s2:string;

begin

init;

mouseinit(n);

mouseshow;

setfillstyle (solidfill,BLACK);

setcolor (WHITE);

settextJustify(centertext, centertext);

x0:=-1; y0:=-1;

repeat

mouseread (x,y,b);

if (x<>x0) or (y<>y0) then begin

str (x,s1); str (y,s2);

bar (getmaxx div 2-50,

getmaxy-15,getmaxx div 2+50,getmaxy-5);

outtextxy (getmaxx div 2,

getmaxy-10,s1+' '+s2);

x0:=x; y0:=y;

end;

until keypressed;

mousehide;

closegraph;

end.



11.3. Тест модуля mouse.pas в текстовом режиме (mousetxt.pas).

program MouseTxt;

uses crt,mouse;

var n,x,y,b:integer;

n1,k,lastx,lasty:word;

begin

textmode(3);

mouseinit (n);

mouseshow;

repeat

mouseread (x,y,b);

gotoxy (1,25);

write ('x=',(x div 8 + 1):2,

' y=',(y div 8 + 1):2,' b=',b:2);

until keypressed;

mousehide;

end.



12.1. Учебная игра, использующая собственный файл ресурсов. Первый листинг содержит утилиту для создания файла ресурсов resfile из файлов *.bmp текущей директории, список которых находится в файле filelist.txt. Файлы *.bmp должны быть сохранены в режиме 16 цветов. При необходимости следует изменить в программе константу пути к Паскалю.

uses graph,crt;

const VGAPath='c:\TP7\egavga.bgi';

FileList='filelist.txt';

resfile='attack.res';

const width=32; height=20;



const color: array [0..15] of byte=

(0,4,2,6,1,5,3,7,8,12,10,14,9,13,11,15);

const maxx=639; maxy=479;

cx=MAxx div 2; cy=maxy div 2;

type bmpinfo=record

h1,h2:char;

size,reserved,offset,b,width,

height: longint;

plans,bpp:word;

end;

var Driver, Mode: integer;

DriverF: file; List,res:text;

DriverP: pointer; s:string;



procedure Wait;

var ch:char;

begin

reset (Input); repeat until keyPressed;

ch:=readkey; if ch=#0 then readkey;

end;



procedure closeMe;

begin

if DriverP <> nil then begin

FreeMem(DriverP, Filesize(DriverF));

close (DriverF);

end;

closegraph;

end;



procedure graphError;

begin

closeMe;

writeln('graphics error:',

grapherrormsg(graphresult));

writeln('Press any key to halt ');

Wait;

halt (graphresult);

end;



procedure InitMe;

begin

assign(DriverF, VGAPath);

reset(DriverF, 1);

getmem(DriverP, Filesize(DriverF));

Blockread(DriverF, DriverP^,

Filesize(DriverF));

if registerBGIdriver(DriverP)<0 then

graphError;

Driver:=VGA; Mode:=VGAHi;

initgraph(Driver, Mode,'');

if graphresult < 0 then graphError;

end;



procedure clearscreen;

begin

setfillstyle (solidfill, White);

bar (0,0,maxx,maxy);

end;



procedure Window

(x1,y1,x2,y2,color,Fillcolor:integer);

begin

setcolor (color);

setfillstyle (1,Fillcolor);

bar (x1,y1,x2,y2);

rectangle (x1+2,y1+2,x2-2,y2-2);

rectangle (x1+4,y1+4,x2-4,y2-4);

setfillstyle (1,DArKGrAy);

bar (x1+8,y2+1,x2+8,y2+8);

bar (x2+1,y1+8,x2+8,y2);

end;



procedure Error (code:integer; str:string);

begin

Window (cx-140,cy-100,cx+140,

cy-70,Black,YELLOW);

case code of

1: s:='Файл '+str+' не найден!';

2: s:='Файл '+str+' не формата BMP-16';

3: s:='Файл '+str+' испорчен!';

end;

settextjustify (Lefttext, toptext);

settextstyle(DefaultFont, HorizDir, 1);

outtextxy (cx-136,cy-92,s);

Wait;

halt(code);

end;



function Draw (x0,y0:integer; fname:string;

transparent:boolean):integer;

var f:file of bmpinfo;

bmpf:file of byte;

res:integer; info:bmpinfo;

x,y:integer; b,bh,bl:byte;

nb,np:integer; tpcolor:byte;

i,j:integer;

begin

assign(f,fname);

{$I-} reset (f); {$I+}

res:=IoResult;

if res <> 0 then Error (1,fname);

read (f,info);

close (f);

if info.bpp<>4 then Error(2,fname);

x:=x0;

y:=y0+info.height;

nb:=(info.width div 8)*4;

if (info.width mod 8) <> 0 then nb:=nb+4;

assign (bmpf,fname);

reset (bmpf);

seek (bmpf,info.offset);

if transparent then begin

read (bmpf,b);

tpcolor:=b shr 4;

seek (bmpf,info.offset);

end

else tpcolor:=17;

for i:=1 to info.height do begin

np:=0;

for j:=1 to nb do begin

read (bmpf,b);

if np tpcolor then

putpixel (x,y,color[bh]);

inc (x);

inc(np);

end;

if np tpcolor then

putpixel (x,y,color[bl]);

inc(x);

inc(np);

end;

end;

x:=x0;

dec(y);

end;

close (bmpf);

Draw:=info.height;

end;



var i,j:word;

b:char;

r:integer;

begin

InitMe;

clearscreen;

assign (List,FileList);

{$I-}

reset (List);

{$I+}

if IoResult <> 0 then Error (1,FileList);

assign (res,resfile);

{$I-}

rewrite (res);

{$I+}

if IoResult <> 0 then Error (1,resfile);

settextjustify (centertext,toptext);

while not eof(List) do begin

readLn (List,s);

clearscreen;

Draw (0,0,s,true);

for j:=1 to height do

for i:=1 to width do begin

b:=chr(getpixel (i,j));

write (res,b);

end;

setcolor (BLACK);

outtextxy (cx,maxy-20,'Файл '+s+' ОК');

Wait;

end;

closeMe;

close (res);

close (List);

end.



12.2. Листинг содержит исходный текст игры в стиле Invaders. Компилировать в Паскаль 7. При необходимости изменить константу пути к Паскалю. Требует файла ресурсов, созданного утилитой из листинга 12.1. Требует установленного графического шрифта trip.chr.

uses graph,crt,Dos;

const width=32; height=20;

type Picture=array [0..width-1,0..height-1]

of char;

type sprite=record

state,x,y,Pnum,PREDir: word;

end;

const VGAPath='c:\TP7\egavga.bgi';

FontPath='c:\TP7\Trip.chr';

sprName='attack.res';

const ESC=#27; F1=#59; SPACE=#32;

UP=#72; DOWN=#80; LEFT=#75; RIGHT=#77;

const maxx=639; maxy=479;

cx=maxx div 2; cy=maxy div 2;

maxsprites=11; maxPictures=11;

maxshoots=100;

const LeftDir=0; RightDir=1;

UpDir=2; DownDir=3;

Delta=2; shootradius=5;

var ch:char; s:string;

Hour,min,sec,sec1,secN,secN1,

sec100,secI,secI1:word;

var Driver, Mode, Font1,

currentsprites, currentBottom,

currentshoots, shootx, Lives,

Enemyshooter, Enemies,

shootsProbability: integer;

score,Level:longint;

DriverF,FontF: file;

DriverP,FontP: pointer;

spr: array [1..maxsprites] of sprite;

Pict: array [1..maxPictures] of Picture;

shoots: array [1..maxshoots] of sprite;

shooter,DieMe,InGame,Initshoot:boolean;



procedure Wait;

var ch:char;

begin

reset (Input); repeat until keyPressed;

ch:=readkey; if ch=#0 then readkey;

end;



procedure closeAll;

begin

if FontP <> nil then begin

FreeMem(FontP, Filesize(FontF));

close (FontF);

end;

if DriverP <> nil then begin

FreeMem(DriverP, Filesize(DriverF));

close (DriverF);

end;

closegraph;

end;



procedure graphError;

begin

closeAll;

writeln('graphics error:',

grapherrormsg(graphresult));

writeln('Press any key to halt');

Wait; halt (graphresult);

end;



procedure InitAll;

begin

assign(DriverF, VGAPath);

reset(DriverF, 1);

getmem(DriverP, Filesize(DriverF));

Blockread(DriverF, DriverP^,

Filesize(DriverF));

if registerBGIdriver(DriverP)<0 then

graphError;

Driver:=VGA; Mode:=VGAHi;

initgraph(Driver, Mode,'');

if graphresult < 0 then graphError;

assign(FontF, FontPath);

reset(FontF, 1);

getmem(FontP, Filesize(FontF));

Blockread(FontF, FontP^, Filesize(FontF));

Font1:=registerBGifont(FontP);

if Font1 < 0 then graphError;

end;



procedure clearscreen;

begin

setfillstyle (solidfill, White);

bar (0,0,maxx,maxy);

end;



procedure Window

(x1,y1,x2,y2,color,Fillcolor:integer);

begin

setcolor (color);

setfillstyle (1,Fillcolor);

bar (x1,y1,x2,y2);

rectangle (x1+2,y1+2,x2-2,y2-2);

rectangle (x1+4,y1+4,x2-4,y2-4);

setfillstyle (1,DArKGrAy);

bar (x1+8,y2+1,x2+8,y2+8);

bar (x2+1,y1+8,x2+8,y2);

end;



procedure outtextcxy (y:integer; s:string);

begin

settextjustify (centertext,centertext);

outtextxy (cx ,y,s);

end;



procedure start;

begin

clearscreen;

Window (10,10,maxx-10,maxy-10,Blue,White);

settextstyle(Font1, HorizDir, 4);

outtextcxy (25,'Атака из космоса');

settextstyle(Font1, HorizDir, 1);

outtextcxy (maxy-25,

'Нажмите клавишу для начала');

Wait;

end;



procedure restorescreen

(sNum,Dir,Delta:word);

var x,y:word;

begin

x:=spr[sNum].x; y:=spr[sNum].y;

setfillstyle (solidfill,White);

case Dir of

LeftDir: begin

bar(x+wic-mDelta,y,x+wic-m1,

y+heighg-1);

end;

RightDir: begin

bar (x,y,x+Delta,y+heighg-1);

end;

UpDir: begin

bar (x,y+heighg-Delta,

x+wic-m1,y+heighg-1);

end;

DownDir: begin

bar (x,y,x+wic-m1,y+Delta);

end;

end;

end;



procedure Drawsprite (sNum:word);

var i,j,x,y,n,b:integer;

begin

N:=spr[sNum].PNum;

x:=spr[sNum].x; y:=spr[sNum].y;

for j:=y to y+heighg-1 do

for i:=x to x+wic-m1 do begin

b:=ord(Pict[n,i-x,j-y]);

putpixel(i,j,b);

end;

end;



procedure GoLeft;

var x,d2:word;

begin

x:=spr[1].x; d2:=delta*4;

if x>d2 then begin

restorescreen (1,LeftDir,d2);

Dec(spr[1].x,d2); Drawsprite (1);

end;

end;



procedure GoRight;

var x,d2:word;

begin

x:=spr[1].x;

d2:=delta*4;

if x+width < maxx then begin

restorescreen (1,RightDir,d2);

Inc(spr[1].x,d2);

Drawsprite (1);

end;

end;



procedure showLives;

begin

str(Lives,s);

setfillstyle (solidfill,White);

setcolor (RED); bar (80,0,110,10);

outtextxy (82,2,s);

end;



procedure showscore;

begin

str(score,s);

setfillstyle (solidfill,White);

setcolor (Blue); bar (150,0,250,10);

outtextxy (152,2,s);

end;



procedure showshoots;

begin

str(currentshoots,s);

setfillstyle (solidfill,White);

setcolor (Black); bar (20,0,50,10);

outtextxy (20,2,s);

end;



procedure showLevel;

begin

str(Level,s);

setfillstyle (solidfill,White);

setcolor (Blue); bar (251,0,350,10);

outtextxy (253,2,'Level '+s);

end;



procedure shoot;

var i:integer;

begin

if currentshoots>0 then begin

for i:=1 to maxshoots do

if (sec<>sec1) and (shoots[i].state=0)

then begin

Dec(currentshoots);

showshoots;

spr[1].PNum:=6; Drawsprite (1);

GetTime(Hour,min,sec,sec100);

shootx:=spr[1].x; shooter:=true;

shoots[i].x:=spr[1].x+ (width div 2);

shoots[i].y:=spr[1].y - 5;

shoots[i].PNum:=UpDir;

shoots[i].state:=1;

break;

end;

end;

end;



procedure Help(s:string);

begin

setfillstyle (solidfill,White);

setcolor (Blue);

bar (10,maxy-10,maxx-10,maxy);

outtextxy (10,maxy-9,s);

end;



procedure Error (code:integer; str:string);

begin

Window (cx-120,cy-100,cx+120,cy-70,

Black,YELLOW);

case code of

1: s:='Файл '+str+' не найден!';

end;

settextjustify (Lefttext, toptext);

settextstyle(DefaultFont, HorizDir, 1);

outtextxy (cx-116,cy-92,s);

Wait; closeAll; halt(code);

end;



procedure DrawField;

var i,x,y:integer;

begin

clearscreen;

with spr[1] do begin

state:=1; Pnum:=1;

x:=maxx div 2;

y:=maxy - 10 - height;

Drawsprite (1);

end;

x:=100;

y:=10;

for i:=2 to currentsprites do begin

spr[i].state:=1;

spr[i].PNum:=7;

spr[i].x:=x; spr[i].y:=y;

Drawsprite (i);

inc(x,50);

if x>maxx-width then begin

x:=100;

if y0 then Error (1,sprName);

for n:=1 to maxPictures do

for j:=0 to height-1 do

for i:=0 to width-1 do begin

read (f,b);

Pict [n,i,j]:=b;

end;

close (f);

end;



procedure Deltas (sNum,Dir:integer;

var dx,dy:integer);

var x,y:integer;

begin

x:=spr[sNum].x; y:=spr[sNum].y;

case Dir of

LeftDir: begin

Dec(x,Delta);

if x<0 then x:=0;

end;

RightDir: begin

Inc(x,Delta);

if x>maxx-width then x:=maxx-width;

end;

UpDir: begin

Dec (y,Delta);

if y<10 then y:=10;

end;

DownDir: begin

Inc(y,Delta);

if y>currentBottom then

y:=currentBottom;

end;

end;

dx:=x; dy:=y;

end;



function Between (a,x,b:integer):boolean;

begin

if (x>a) and (xmaxy-10-(height div 2) then begin

shoots[i].state:=0;

continue;

end;

found:=false;

if Between(spr[1].x,x,spr[1].x+width)

and

Between(spr[1].y,y,spr[1].y+height)

then begin

shoots[i].state:=0; found:=true;

Inc(spr[1].Pnum); DieMe:=true;

Help ('you are missed one life :-(');

Drawsprite (1);

end;

if not found then Inc(y,Delta);

end;

if not found then begin

fillellipse(x,y,shootradius,shootradius);

shoots[i].x:=x; shoots[i].y:=y;

end;

end;

end;



procedure Enemiesstep;

var i,k,Dir,dx,dy,n:integer;

begin

Enemies:=0;

for i:=2 to currentsprites do begin

if spr[i].state=1 then begin

Inc(Enemies);

for k:=1 to 3 do begin

dir:=random(4);

if dir=spr[i].pREDir then break;

end;

spr[i].pREDir:=dir;

Deltas (i, dir, dx, dy);

restorescreen (i,Dir,Delta);

spr[i].x:=dx; spr[i].y:=dy;

Drawsprite (i);

Initshoot:=false;

GetTime(Hour,min,secN1,sec100);

if (secN1<>secN) and

(1+random(100)i) then begin

Enemyshooter:=i;

shoots[n].x:=dx+ (width div 2);

shoots[n].y:=dy +height +5;

shoots[n].PNum:=DownDir;

shoots[n].state:=1;

break;

end;

end;

end

else if spr[i].state=2 then begin

GetTime (Hour,min,secI,sec100);

Drawsprite (i);

if secI<>secI1 then begin

secI1:=secI;

if (spr[i].PNum<11) then

Inc(spr[i].PNum)

else begin

spr[i].state:=0;

setfillstyle (solidfill, White);

bar (spr[i].x,spr[i].y,

spr[i].x+wic-m1,spr[i].y+heighg-1);

end;

end;

end;

end;

end;



procedure Timefunctions;

var i:integer;

begin

if not InGame then Exit;

GetTime(Hour,min,sec1,sec100);

if (shooter) and (sec<>sec1) then begin

spr[1].PNum:=1;

if shootx=spr[1].x then Drawsprite (1);

shooter:=false;

end;

if (DieMe) and (sec<>sec1) then begin

if spr[1].Pnum<5 then begin

sec:=sec1; Inc(spr[1].PNum);

Drawsprite (1); DieMe:=true;

end

else begin

DieMe:=false;

if Lives>0 then begin

Dec(Lives); showLives;

spr[1].PNum:=1;

Drawsprite (1);

end

else InGame:=false;

end;

end;

end;



function getlongintTime:longint;

{Вернет системное время как longint}

var Hour,minute,second,sec100: word;

var k,r:longint;

begin

GetTime (Hour, minute, second, sec100);

k:=Hour; r:=k*360000;

k:=minute; Inc (r,k*6000);

k:=second; Inc(r,k*100);

Inc(r,sec100); getlongintTime:=r;

end;



procedure Delay (ms:word);

var endTime,curTime : longint;

cor:boolean;

begin

cor:=false;

endTime:=getlongintTime + ms div 10;

if endTime>8639994 then cor:=true;

repeat

curTime:=getlongintTime;

if cor=true then begin

if curTime<360000 then

Inc (curTime,8639994);

end;

until curTime>endTime;

end;



label 10,20;

begin

randomize; InitAll; InGame:=false;

start;

settextstyle (DefaultFont,HorizDir,1);

settextjustify (Lefttext,toptext);

Loadsprites;

currentBottom:=200; currentshoots:=50;

Lives:=3; score:=0; Level:=1;

shootsProbability:=5;

currentsprites:=5;

10:

DrawField;

if Level>1 then begin

str(Level-1,s);

Help ('cool, you''re complete level '+s);

end

else Help

('Let''s go! Kill them, invaders!');

repeat

if InGame then repeat

Enemiesstep;

if Enemies=0 then begin

Inc(score,100+Level*10);

if shootsProbability<100 then

Inc (shootsProbability);

if currentsprites/pers.narod.ru/study/pascal/p4.html;[/url] Fri, 27 Feb 2009 18:45:15 GMT; гостевая; E-mail


Поиск сообщений в xpackpackax
Страницы: 25 ... 22 21 [20] 19 18 ..
.. 1 Календарь