Статьи по Delphi (027)…

Крестики - нолики с CORBA.

Известно расшифровывается как Common Object Request Broker Architecture, и представляет собой объектно-ориентированную архитектуру связи между клиентом и сервером. Приложения на основе CORBA состоят из двух частей: CORBA-сервер и CORBA-клиент. И сервер и клиент могут быть реализованы на любом языке и запущены на любой платформе. CORBA представляет собой независимую от языка программирования и операционной системы технологию. Это возможно, так как все параметры и типы, возвращаемые методами транспортируются через сеть в специально универсальном формате. А вот для того чтобы сервер и клиент понимали друг друга необходимо определить интерфейс CORBA-сервера, при этом необходимо учитывать независимость от операционной системы и языка на котором происходит разработка приложения. Для этой цели и был разработан интерфейс общения клиента и сервера Interface Definition Language (IDL). Используя IDL, можно определять специфические объекты с присущими им методами и свойствами. Данные методы подобны функциям, которые могут быть вызваны клиентом, и которые могут быть реализованы сервером. В Delphi например для реализации подобного интерфейса прийдеться компилировать специализированный IDL-файл. Вообще же преобразование из стандартного внутреннего стандарта языка программирования в подобный переносимый формат обозначают как marshalling. Обратный процесс преобразования из универсального формата в стандарт понятный программе называется unmarshalling.

Краткое пособие по языку INFORMIX-4GL.

Краткое пособие по языку INFORMIX-4GL.

Краткое пособие по языку INFORMIX-4GL.

Соглашения о Языке 4GL и Начальные Понятия.

Программа на языке 4GL может состоять из нескольких файлов (модулей) с исходными текстами на 4GL. К ней так же относятся файлы с описанием используемых экранных форм, которые компилируются отдельно. Имя каждого модуля должно иметь расширение .4gl (например, module1.4gl), а имя файла с описанием экранных форм должно иметь расширение .per (например, form2.per). Каждый модуль содержит описания переменных и несколько процедурных блоков function (подпрограммы) и report (блоки печати). В программе должен быть один блок main - главный блок, начинающийся с ключевого слова main. На него будет передаваться управление при старте программы. Формат записи операторов 4GL свободный. Можно писать все подряд на одной строке, один оператор на нескольких строках, слова операторов можно разделять произвольным количеством пробелов и комментариев. Никакими значками (типа ;) операторы разделять не нужно. Окончание операторов определяется по контексту. Весь набор ключевых слов языка зарезервирован, их нельзя занимать для других целей (на имена объектов и переменных 4GL). Компилятору языка безразлично, большими или маленькими буквами пишутся операторы. Он их не различает.

Комментарии обозначаются знаками { комментарий }, или знаком # - до конца строки, или знаком -- (два знака минус) до конца строки.

Объекты, Используемые в INFORMIX-4GL.

1. Объекты SQL 2. Переменные 4GL 3. Программные

Имя базы данных простая переменная функция

Имя таблицы переменная типа "запись" отчет

Имя столбца массив метка

Имя индекса

Имя псевдотаблицы

Имя синонима

( database-name простые переменные function ).

( table-name переменная типа запись report ).

( column-name массивы label ).

( index-name ).

( view-name ).

( synonim-name ).

4. Имена операторов 5. Объекты экранного обмена.

и курсоров

Window.

Statement-id - изготовленный оператор form.

Cursor-name - курсор screen-field.

Screen-record.

Screen-array.

1. Идентификаторы INFORMIX. Каждый объект 4GL имеет имя (идентификатор) - это слово, состоящее из букв, цифр, и знаков подчеркивания (_), начинающееся с буквы или знака (_). В INFORMIX-4GL не различаются маленькие и большие буквы. Поэтому i_Un103Tt и I_UN103TT - одно и тоже имя.

1. Области Действия Имен Переменных:

· Локальная переменная - объявлена внутри блока function, main, report. Действует внутри блока, в котором объявлена.

· Модульная переменная должна быть объявлена в самом начале модуля с исходным текстом вне любого блока report, function или main. Действует внутри всего модуля (за исключением блоков, в которых это имя переобъявлено и является для них локальным).

· Глобальные переменные - объявляются с помощью оператора GLOBALS в начале модулей. Действуют во всех модулях с исходным текстом, в которых есть соответствующее объявление этих переменных.

1. Область действия имен КУРСОРОВ и Изготовленных Операторов от точки их объявления (DECLARE, PREPARE) и до конца модуля.

1. Область действия имен Окон, Форм, Функций, Отчетов - во всей программе.

В Языке 4GL Есть Такие Операторы:

Операторы SQL.

Организация программы

MAIN.

FUNCTION.

REPORT.

Объявления переменных

DEFINE.

GLOBALS.

Присвоения

LET.

INITIALIZE.

Программные

CALL EXIT GOTO.

RETURN FOR LABLE.

CASE WHILE RUN.

IF CONTINUE SLEEP.

Перехват прерываний

WHENEVER.

DEFER.

Динамическое создание операторов

PREPARE EXECUTE FREE.

Манипуляция "курсором".

DECLARE.

OPEN FOREACH PUT.

CLOSE FETCH FLUSH.

Экранный обмен

MENU OPEN FORM DISPLAY ARRAY.

OPTIONS DISPLAY FORM SCROLL.

OPEN WINDOW CLOSE FORM INPUT ARRAY.

CURRENT WINDOW DISPLAY PROMPT.

CLEAR INPUT ERROR.

CLOSE WINDOW CONSTRUCT MESSAGE.

Генерация отчетов

START REPORT.

OUTPUT TO REPORT.

FINISH REPORT.

Типы Переменных и Операторы Описания Переменных в 4GL.

В языке 4GL имеются простые переменные, переменные типа запись и массивы. Простые переменные бывают следующих типов:

INTEGER CHAR(n) DATE.

SMALLINT DECIMAL(m,n) DATETIME ед_врем1 TO ед_врем2.

REAL MONEY(m,n) INTERVAL ед_врем1 TO ед_врем2.

FLOAT.

где ед_врем1, ед_врем2 - единицы измерения времени

{YEAR,MONTH,DAY,HOUR,MINUTE,SECOND,FRACTION(n)}.

где FLOAT = DOUBLE PRECISSION Переменная типа запись описывается при помощи конструкции RECORD ... END RECORD или конструкции LIKE имя_таблицы.* Переменная типа массив имеет описатель ARRAY [i,j,k] OF type, где type - тип простой переменной, конструкция RECORD, или конструкция ARRAY. Для описания переменных служит оператор DEFINE:

DEFINE simw char (200), j,i,k INTEGER, ff FLOAT.

# Здесь объявлены символьная переменная simw длиной 200 байт,

# целые i,j,k, и ff - восьмибайтовое с плавающей точкой

DATABASE zawod.

DEFINE doljno RECORD.

# объявляется запись doljno, состоящая из 4 простых переменных

Dolzn CHAR(20), # должность

Zarplmin LIKE kadry.zarplata,

Zarplmax money(16,2), # зарплата

Vakansii int # вакансии

END RECORD # Здесь заканчивается объявление записи doljno.

# Переменную можно оъявить с ключевым словом LIKE column_name.

# переменная zarplmin получает такой же тип, что и столбец

# zarplata таблицы kadry из базы данных zawod.

DEFINE rrr RECORD LIKE kadry.*

# Переменную типа запись тоже можно объявить с ключевым словом

# LIKE. Здесь объявлена запись rrr, содержащая элементы, имею-

# щие те же самые названия и те же самые типы что и столбцы

# таблицы kadry.

Элементами записи могут быть массивы. Можно обьявить массив элементов типа RECORD.

DEFINE zap RECORD.

A LIKE kadry.tabnom,

B array[8] OF REAL.

END RECORD,

Massiw ARRAY[2,15] OF RECORD.

Kolwo INT,

Tip CHAR(8).

END RECORD.

# massiw объявлен как массив записей. Каждая запись состоит

# из двух простых элементов - kolwo и tip.

Индексы массивов пишутся в квадратных скобках. На элементы записей можно ссылаться по его имени, если не допускается двусмысленности, иначе их необходимо уточнять именем записи, отделяя его точкой (.) от простого имени.

# присвоить значение элементу массива можно так:

LET massiw[1,i+2].kolwo = zap.a + LENGTH(massiw[1,i+2].tip).

Для сокращения перечисления элементов в списках можно пользоваться нотацией (*). Например, strkt.* означает все элементы записи strkt. А так же нотацией THRU: (элементы записи от и до).

SELECT kadry.* INTO strkt.* FROM kadry WHERE kadry.tabnom=i+j.

SELECT * INTO strukt.b THRU strkt.e FROM kadry.

Глобальные переменные должны иметь одинаковые объявления GLOBALS во всех модулях программы (в которых используются). Проще всего это организуется так: заводится отдельный модуль, в котором ничего, кроме объявлений GLOBALS нет. А во всех остальных модулях программы ссылаются на этот файл. Ниже приводится пример объявления глобальных переменных в файле progrglob.4gl:

DATABASE zawod.

GLOBALS.

DEFINE zap RECORD LIKE kadry.*

DEFINE ext_count INT.

. . .

END GLOBALS.

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

GLOBALS "progrglob".

. . .

Подпрограммные Блоки (Функции).

В языке 4GL при программировании функций (подпрограмм) используются операторы function. Все аргументы функции должны быть объявлены. Аргументы передаются по значению. Если функция возвращает какие-либо значения, то при вызове ее нужно воспользоваться в операторе CALL предложением RETURNING с перечислением переменных, в которые возвращается значение. Ниже приводится соответствующий фрагмент программы.

FUNCTION stroka(rec).

DEFINE rec RECORD i int, st char(256) END RECORD.

RETURN st clipped,"автопробега".

END FUNCTION.

. . .

MAIN.

. . .

CALL stroka(rec1.*) RETURNING simw.

. . .

LET simw=stroka(7,"Привет участникам ").

# Если функция возвращает одно значение, то ее имя мож-

# но использовать в выражениях.

MESSAGE simw.

. . .

END MAIN.

На экране пользователь увидит:

ѓЃѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹‚

ѓЉ Привет участникам автопробега ѓЉ

ѓЉ ѓЉ

ѓЉ ѓЉ

ѓЉ ѓЉ

ѓѓѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹„

Примеры Использования Программных Операторов.

Оператор безусловного перехода действует в пределах модуля.

GOTO metka.

. . .

LABEL metka: . . .

Оператор выбора.

CASE.

WHEN iscreen=1.

Current window is w1.

WHEN iscreen=2.

Current window is w2.

Let iscreen=1.

OTHERWISE.

Current window is SCREEN.

END CASE.

CASE (a+b) # Другой формат оператора CASE.

WHEN 1.

Message "a=",a.

WHEN 2.

Message "b=",b.

END CASE.

Условный оператор.

IF str = "завершить" OR y<0 THEN exit program # Не забывайте в конце каждого условного # оператора ставить END IF. END IF.

Оператор цикла.

FOR I= i1 TO 23.

Let a[i]=0.

If b[i]=100 then.

EXIT FOR.

END IF.

END FOR.

Цикл "пока".

WHILE ff > 3 or nn="проба".

PROMPT "Введите число " for n.

Let i=n+1.

Message "А у меня ",i,", больше. Вы проиграли.".

SLEEP 5.

RUN "rm *" WITHOUT WAITING.

END WHILE.

Динамическое Изготовление Операторов SQL. Курсоры.

Операторы PREPARE и EXECUTE предназначены для динамического (во время выполнения программы) изготовления и выполнения операторов языка SQL (не 4GL !!!). В приведенном ниже фрагменте в ответ на запрос пользователь сможет ввести с клавиатуры строку с оператором языка SQL (Пусть, например, он введет строку: DROP DATABASE buhgalteriq). Программа изготовит из этой строки настоящий оператор и выполнит его с помощью оператора EXECUTE. Если при выполнении зарегистрирована ошибка, о чем сообщит установленный в отрицательное значение код завершения status, пользователя снова попросят ввести оператор.

DEFINE stroka char(200).

MAIN.

. . .

LABEL METK2:PROMPT "введите оператор языка SQL: " FOR stroka.

WHENEVER ERROR CONTINUE # Включить режим "В случае

# ошибки продолжить выполнение

# программы".

PREPARE st1 FROM stroka # Изготовить оператор из

# символьной строки

EXECUTE st1 # Выполнить изготовленный оператор

IF status<0 THEN ERROR "ошибка номер ", status, " в вашем операторе" GOTO metk2 END IF WHENEVER ERROR STOP # Восстановить режим # "В случае ошибки прервать # выполнение программы" . . . END MAIN.

В системную переменную status помещается код выполнения каждого оператора 4GL (status=0 если все нормально, status<0 если произошла ошибка). Переменная status может проверяться после любого оператора программы и в зависимости от ее значения могут предприниматься какие-либо действия.

Курсоры

Если запрос к таблице возвращает несколько (больше одной) строк, то для их обработки используется так называемый курсор - указатель во множестве строк, выбранных оператором SELECT. Оператором DECLARE объявляется курсор для запроса, оператором OPEN этот запрос фактически выполняется и выбранные строки выделяются. Курсор устанавливается на первую из выбранных строк. С помощью оператора FETCH вы можете брать очередную строку, на которую указывает курсор, и помещать ее в свои программные переменные. Курсор после этого смещается на следующую строку. С помощью конструкции циклической FOREACH имя_курсора ... END FOREACH можно перебрать все строки, выбранные оператором SELECT. Оператор OPEN в этом случае не нужен.

DATABASE zawod.

DEFINE zap RECORD LIKE kadry.*

DECLARE curs1 CURSOR FOR.

Select * from kadry where datarovd>"9/25/1973".

# в цикле FOREACH выводим на экран все строки таблицы kadry,

# в которых столбец datarovd содержит дату после 25 сентября

# 1973 года.

FOREACH curs1 INTO zap.* # Берем очередную строку и по-

# мещаем ее в запись zap.

MESSAGE zap.* # Выводим запись zap на экран

PROMPT "Еще ?" FOR CHAR c.

END FOREACH # Конец цикла FOREACH.

В следующем примере строки выбираемые из таблицы kadry через курсор curs2 помещаются в массив z1 (но не более 100 строк).

DATABASE zawod.

DEFINE z1 ARRAY[100] OF RECORD LIKE kadry.*, counter int.

DECLARE curs2 CURSOR FOR SELECT * FROM kadry.

WHERE datarovd<"9/26/1973" OPEN curs2 FOR counter="1" TO 100 FETCH curs2 INTO z1[counter].* # взять очередную строку и поместить ее в следующий элемент # массива z1 IF status="NOTFOUND" THEN # если выбранные сроки кончились, закончить цикл EXIT FOR END IF END FOR LET counter="counter-1" MESSAGE "В массив z1 прочитано ",counter, " записей".

Этот пример демонстрирует еще одно использование переменной status. Если оператор FETCH пытается взять сроку из курсора когда тот уже пуст, то значение переменной status устанавливается равным символической константе NOTFOUND, имеющей значение 100. Поэтому можно проверять значение status после оператора FETCH и если оно равно 100, то прекратить чтение строк из опустевшего курсора. В данном примере пользователь сам должен ввести условия, по которым будут найдены строки в таблице ceh. Он, например, может ввести: "nomerceh>15 and nomerceh<23". Программа прицепит это условие к строке, в которой записан SELECT оператор, получит строчку "SELECT * FROM ceh WHERE nomerceh>15 and nomerceh<23", изготовит из нее оператор, и для этого изготовленного оператора SELECT объявит курсор. Дальше действия аналогичны предыдущему примеру.

DEFINE z2 ARRAY[100] OF RECORD LIKE ceh.*,

Counter int, simw char(200).

PROMPT "допишите оператор SELECT * FROM ceh WHERE " FOR simw.

IF LENGTH(simw)=0 THEN.

LET simw="TRUE".

END IF.

LET simw="SELECT * FROM ceh WHERE ", simw CLIPPED.

PREPARE st2 FROM simw.

DECLARE cs2 FOR st2.

Let counter=1.

FOREACH cs2 INTO z2[counter].*

LET counter=counter+1.

IF counter>100 THEN.

EXIT FOREACH.

END IF.

END FOREACH.

LET counter=counter-1.

MESSAGE "В массив z2 прочитано ",counter, " записей".

Программирование Экранного Обмена.

В любой момент времени на экране терминала существует ТЕКУЩЕЕ окно, через которое и выполняется ввод/вывод вашей программы. С окном связаны используемые при вводе и выводе атрибуты (например, green, revers, underline и т.п.) и номера строк окна, используемых операторами MESSAGE, PROMPT и ERROR для вывода. При открытии нового окна оно становится текущим и и весь ввод/вывод будет направляться уже в него. В окно можно вывести экранную форму, которая, представляет собой набор экранных полей, имеющих имена, и в эти поля (из этих полей), обращаясь к ним по имени, можно выводить (вводить) данные с помощью оператора DISPLAY (INPUT). Экранные поля можно объединять в экранные записи. Описание экранных полей и самой формы располагается отдельно от программы в файле описания экранной формы. Ниже приведен пример программы, иллюстрирующий работу с окнами.

OPEN WINDOW wind1 AT 2,30 WITH 10 ROWS, 40 COLUMNS.

ATTRIBUTE(BORDER, REVERSE, MESSAGE LINE FIRST).

# текущим окном является wind1.

. . .

OPEN WINDOW wind2 AT 5,15 WITH FORM "schoolp".

ATTRIBUTE(GREEN,PROMPT LINE LAST,

MESSAGE LINE LAST, FORM LINE FIRST).

# текущим окном является wind2.

CLEAR WINDOW wind1.

. . .

CURRENT WINDOW IS wind1.

# текущим окном является wind1.

OPEN FORM form1 from "schoolp" # Инициализировать форму form1.

# Взяв ее описание из файла

# schoolp.frm.

DISPLAY FORM form1 # Вывести форму form1 в текущее окно

# т.е. в wind1.

В результате работы этих операторов на экране терминала появится приблизительно такая картинка:

ѓ'ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ'

ѓљ ѓ'ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ' окно ѓљ

ѓљ ѓљ значение равно 8 ѓљ ...ѓwind1 ѓљ

ѓљ ѓ'ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ'

ѓљ ѓљ цех [ 2] [литейный ] ѓљ ѓљѓщѓ‹ѓ„ ѓљ

ѓљ ѓљ таб.номер [26 ] ѓљ ѓљ окно ѓљ

ѓљ ѓљ фамилия [Петров У.Е. ] ѓљ ѓљ ...ѓ wind2 ѓљ

ѓљ ѓљ должность [бригадир ] ѓљ ѓљ ѓЉ ѓљ

ѓљ ѓљ зарплата [$340 ] ѓљѓщѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ‹ѓ„ѓљ

ѓљ ѓљ дата рождения [31.12.1952] ѓљ ѓљ ѓљ

ѓљ ѓљ ѓљ ѓљ ѓљ

ѓљ ѓ"ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ".

ѓљ ѓљ 789 ѓљ ѓљ

ѓљ ѓ"ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ".

ѓљ ѓљ

ѓљ нет таких ѓљ

ѓ"ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ".

Операторы MENU. MESSAGE. PROMPT.

В результате работы фрагмента программы

Let sta_return=podtwervdenie(" В самом деле решили закончить? ").

...

Function podtwervdenie(stroka).

Define stroka char(38) , kod_wozwr int.

Open window podtwervdenie AT 11,10 WITH 4 rows, 39 columns ATTRIBUTE(border).

Display stroka at 4, 2 attribute (reverse).

Menu " ".

Command key("Y") " Yes " "Действительно Да.".

Let kod_wozwr=1.

Exit menu.

Command key("N",ESC) " No " "Нет, вернуться обратно.".

Let kod_wozwr=0.

Exit menu.

Command key("A") " Abort " "Отменить. И кончить.".

Let kod_wozwr=-1.

Exit menu.

End menu.

Close window podtwervdenie.

Return kod_wozwr.

End function.

на экране в текущем окне появится такое меню

+---------------------------------------+

| : Yes No Abort |

|Действительно Да. |

| |

| В самом деле решили закончить? |

+---------------------------------------+

Оператор OPTIONS.

Оператор OPTIONS может установить новые режимы для ввода вывода, если вас не устраивают заданные по умолчанию.

OPTIONS MESSAGE LINE 23,

HELP FILE "h4gl.txt", HELP KEY CONTROL-T,

DISPLAY ATTRIBUTE(REVERSE, UNDERLINE).

Операторы MESSAGE, ERROR.

Оператор MESSAGE выводит строку значений на экран на message line. Аргументами MESSAGE могут быть переменные и константы, но не выражения.

Let ttmm=CURRENT.

Message "Московское время ", ttmm.

Error "Данных больше нет, прочитанно ", n, " строк".

Оператор ERROR делает тоже, что и MESSAGE, только со звонком и с атрибутом REVERSE. Сообщение выводится на 24-ю строку экрана.

Оператор PROMPT.

Оператор PROMPT выводит на экран display-list - список значений переменных и констант, и вводит после этого с клавиатуры значение в указанную вслед за ключевым словом FOR переменную.

PROMPT "Да или нет ?" FOR answer.

ON KEY (CONTROL-U).

LET answer=wozderv().

EXIT PROMPT.

END PROMPT.

Можно включить в PROMPT контрольные блоки, выполняющиеся при нажатии заданных клавиш. Если в данном примере во время ввода пользователь нажмет клавишу CTRL-U то выполнятся операторы из ON KEY предложения: будет вызвана функция wozderv() а затем

прерван оператор PROMPT, не завершив ввода.

Операторы обмена с экранной формой

DISPLAY и INPUT.

Оператор DISPLAY выводит данные в поля экранной формы.

DISPLAY a,b,zap[i].nomerceh TO pole1,fscr.* ATTRIBUTE(BOLD).

Если имена выводимых переменных совпадают с именами экранных полей в текущей экранной форме, то можно применить ключевое слово BY NAME.

DISPLAY BY NAME fio, dolvnostx.

Оператор INPUT используется для ввода значений через поля экранной формы. Можно предусмотреть дополнительные действия при вводе. Для этого в оператор можно включить контрольные блоки AFTER, BEFORE, ON KEY.

INPUT kadr.* FROM fio, dolvnostx, nomerceh.

BEFORE FIELD nomerceh.

Message "Сегодня обслуживаются цеха 5 и 6".

Sleep 2.

Message "".

AFTER FIELD nomerceh.

IF kadr.nomerceh > 6 then.

MESSAGE "Нет такого цеха, повторите".

NEXT FIELD NOMERCEH.

ENF IF.

END INPUT.

Фрагмент, реализующий окошко подсказки.

Ниже приведен пример программирования подсказки (в процессе интерактивного диалога) с использованием экранного массива. Таблица ceh содержит два столбца: номер цеха и его название. В приведенном фрагменте вызывается функция wyborceh, которая выводит содержимое таблицы ceh в экранный массив. Пользователь передвигает курсор на название нужного ему цеха и нажимает клавишу CR. Подпрограмма определяет номер цеха и возвращает его вызывающей программе.

DATABASE zawod.

. . .

Let nc= wyborceh().

. . .

FUNCTION wyborceh() # Выбор цеха, для внесения изменений

DEFINE counter int.

DEFINE ceharr ARRAY[25] OF RECORD # массив для хранения

Nomerceh int, # номерцеха данных из таблицы

Nameceh char(20) # название цеха ceh.

END RECORD.

# Открыть окно с рамкой и вывести в него экранную форму cehform.

OPEN WINDOW cehwind AT 4 ,6 WITH FORM "cehform".

ATTRIBUTE(BORDER).

# Объявить курсор для выбора содержимого из таблицы ceh.

DECLARE cehcurs CURSOR FOR.

SELECT * FROM ceh ORDER BY nomerceh.

# Выполнить запрос и все выбранные строки поместить в програм-

# ный массив ceharr.

LET counter = 0.

FOREACH cehcurs INTO ceharr[counter+1].*

LET counter = counter + 1.

IF counter >=25 THEN EXIT FOREACH END IF.

END FOREACH.

# счетчик counter равен фактическому числу строк выданных в

# курсор

MESSAGE "Выберите цех и нажмите CR".

# Вывести в экранный массив cehscreen в экранной форме cehform.

# counter первых строк из программного массива ceharr.

Call set_count(counter).

DISPLAY ARRAY ceharr TO cehscreen.*

ON KEY (CONTROL-M) EXIT DISPLAY.

END DISPLAY.

# Прервать показ экранного массива при нажатии клавиши CR.

# закрыть окно с экранной формой cehform.

CLOSE WINDOW cehwind.

Let counter=arr_curr() #номер строки массива,

#на котором нажато CR.

RETURN ceharr[counter].nomerceh #номер цеха,

#на котором нажато CR.

END FUNCTION.

А это пользователь увидит на экране:

ѓ'ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ'

ѓљ номер цех ѓљ

ѓљ [3 ] [токарный ]ѓљ

ѓљ [4 ] [гараж ]ѓљ

ѓљ [5 ] [конюшня ]ѓљ

ѓљ [6 ] [столовая ]ѓљ

ѓљ [ ] [ ]ѓљ

ѓљ Выберите цех и нажмите CR ѓљ

ѓ"ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ".

Описание и компиляция экранных форм

В приведенном выше фрагменте использована экранная форма cehform.per. Ниже приведено ее описание. Это описание должно лежать в файле cehform.per и должно быть откомпилировано компилятором экранных форм INFORMIX'а form4gl. Описание экранной формы cehform.per.

DATABASE zawod.

SCREEN.

{

номер цех

[f00] [f001 ].

[f00] [f001 ].

[f00] [f001 ].

[f00] [f001 ].

[f00] [f001 ].

}

TABLES.

Ceh.

ATTRIBUTES.

F00 = ceh.nomerceh;

F001 = ceh.nameceh;

INSTRUCTIONS.

Screen record cehscreen[5] (ceh.*).

END.

В секции DATABASE указана база данных; в секции SCREEN задана картинка, которая будет рисоваться на экране; В TABLES указываются таблицы, в ATRIBUTES указываются имена экранных полей, (и, возможно, их атрибуты) а в INSTRUCTIONS объявлен экранный массив cehscreen в пяти строках из двух полей (nomerceh и nameceh).

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

Function kalkulator() # Калькулятор

Define wyravenie, kalkulator char(64), kolichestwo int.

Define stroka_kalkulatora char(200).

Define beep char(1).

Let beep=ascii 7.

Open window kalkulator at 2,2 with form "kalkulator".

Attribute(border, form line first).

Input by name wyravenie, kalkulator without defaults.

Before field kalkulator.

Let stroka_kalkulatora=

"select count(*),",wyravenie," from systables".

Whenever error continue.

Prepare kalkulqtor_operator from stroka_kalkulatora.

If status<0 then display beep to kalkulator display "Неправильное выражение" to kalkulator next field wyravenie end if declare kalkulator cursor for kalkulqtor_operator foreach kalkulator into kolichestwo, kalkulator if status<0 then display beep to kalkulator display "Неправильное выражение" to kalkulator next field wyravenie end if end foreach whenever error stop display kalkulator to kalkulator next field wyravenie end input close window kalkulator return kalkulator end function.

Использованная в подпрограмме экранная форма должна быть описана в файле kalkulator.per и откомпилирована при помощи компилятора form4gl.

DATABASE formonly.

SCREEN.

{

Калькулятор. Чтобы закончить нажмите ESC.

[wyravenie ].

[kalkulator ].

}

ATTRIBUTES.

Wyravenie =formonly.wyravenie;

Kalkulator=formonly.kalkulator;

END.

Пример программы, выдающей отчет

DATABASE zawod.

MAIN.

DEFINE zapisx record like kadry.*

DEFINE simw char (200), zapr char (300),fn char (18).

OPEN form maxprim from "maxprim".

DISPLAY form maxprim # вывести экранную форму

CONSTRUCT BY NAME simw ON kadry.* # Введение критериев выбора

# с экрана

LET zapr="select * from kadry where ",

Simw clipped," order by tabnom ".

MESSAGE simw.

PREPARE selpr FROM zapr # Изготовление запроса

DECLARE qquer CURSOR FOR selpr # Объявление курсора для него

DISPLAY "Не забудьте нажать CTRL-O" AT 2,40.

PROMPT "Файл, куда выводить отчет? или CR, если на экран: ".

FOR fn.

IF length(fn)=0 then START REPORT kadryrep # на экран

Else START REPORT kadryrep TO fn # в файл

END IF.

# выполнить запрос и сбросить выбранные строки в отчет

FOREACH qquer into zapisx.* # Очередную строку из курсора

OUTPUT TO REPORT kadryrep(zapisx.*) # поместить в отчет

END FOREACH.

FINISH REPORT kadryrep # Вывести результаты отчета

END MAIN.

REPORT kadryrep(z).

DEFINE nameceh like ceh.nameceh.

DEFINE z record like kadry.*

# nomerceh int, # номер цеха

# tabnom serial, # табельн. номер

# fio char(20), # фамилия

# dolvn char(20), # должность

# zarplata money(16,2), # зарплата

# datarovd date # дата рожд.

OUTPUT.

Left margin 0.

Right margin 80.

Top margin 0.

Bottom margin 0.

Page length 23.

ORDER BY z.nomerceh, z.tabnom # Упорядочить

FORMAT.

PAGE HEADER.

Print "-------------------------------------------------------".

Print "цех|таб.ном|фио |должность |зарплата| дата рожд".

Print "_______________________________________________________".

ON EVERY ROW.

Print z.nomerceh using "##", column 4,z.tabnom using "#####",

Column 13,z.fio clipped,

Column 28,z.dolvn clipped,

Column 43,z.zarplata using "$####.##",

Column 53,z.datarovd using "dd-mm-yyyy".

BEFORE GROUP OF z.nomerceh.

Select @nameceh into nameceh from ceh where nomerceh=z.nomerceh.

Skip to top of page.

Skip 1 line.

Print "Цех ",nameceh.

Skip 1 line.

AFTER GROUP OF z.nomerceh.

Need 2 lines.

Print " В цехе ",nameceh clipped,2 spaces,

Group count(*) using "#####" ," человек, ".

Print " Средняя зарплата ",

Group avg(z.zarplata) using "##### руб.## коп".

PAGE TRAILER.

Print "заполнена страница номер", pageno.

Pause "нажмите ВВОД".

END REPORT.

Вот что увидит на пользователь во время работы программы:

+-------------------------------------------------------------+

|Укажите файл, куда выводить отчет, или CR, если на экран: |

| Не забудьте нажать CONTROL-О|

| |

|---------------------------------------------- |

| цех [1:4] [ ] |

| таб.номер [ ] |

| фамилия [*ов ] |

| должность [ ] |

| зарплата [>500 ] |

|дата рождения [ ] |

| |

| |

Nomerceh between 1 and 4 and fio matches "*о*" and zarplata>500.

| |

+-------------------------------------------------------------+

---------------------------------------------------------------------------

цех|таб.ном|фио |должность |зарплата| дата рожд

_______________________________________________________________

Цех дирекция

1 34 иванов директор $ 4000.00.

1 35 кононов зав. по снабжению$ 4000.00.

В цехе дирекция 2 человек,

Средняя зарплата 4000 руб.00 коп

заполнена страница номер 1.

нажмите ВВОД

---------------------------------------------------------------------------

цех|таб.ном|фио |должность |зарплата| дата рожд

_______________________________________________________________

Цех литейный

2 12 окунев рабочий $ 2000.00.

2 14 липко лаборант $ 2000.00.

2 18 пухов мастер $ 2000.00.

2 21 сухов рабочий $ 2000.00.

2 24 угольков рабочий $ 2000.00.

В цехе литейный 5 человек,

Средняя зарплата 2000 руб.00 коп

заполнена страница номер 2.

нажмите ВВОД

---------------------------------------------------------------------------

цех|таб.ном|фио |должность |зарплата| дата рожд

_______________________________________________________________

Цех гараж

4 9 потруев слесарь $ 1230.00.

4 12 гундосов шофер $ 2000.00.

В цехе гараж 2 человек,

Средняя зарплата 1615 руб.00 коп

заполнена страница номер 3.

нажмите ВВОД

Описание экранной формы

Описание состоит из 5 разделов: DATABASE, SCREEN, TABLES, ATTRIBUTES, INSTRUCTIONS.

# база данных, с которой ведется работа

DATABASE zawod.

# Картинка, которая выводится на экран.

# экранные поля обозначены так: [метка поля ].

# метка поля используется в разделе ATTRIBUТЕ

SCREEN.

{

номер цеха [nceh ] зарплата [f002 ].

фамилия [fio ].

должность [dol ].

Так в экранной форме рисуется рамка.

Значок \g используется для входа и выхода в графический режим

\gp-----------------------------q\g.

\g|\g Экранный массив \g|\g.

\g|\g [s1 ] [s2 ] \g|\g.

\g|\g [s1 ] [s2 ] \g|\g.

\g|\g [s1 ] [s2 ] \g|\g.

\g|\gномер цеха название цеха \g|\g.

\gb-----------------------------d\g.

в графическом режиме символы р q b d - | заменяются

символами рисования рамки ѓ' ѓ' ѓ" ѓ" ѓ› ѓљ

}

TABLES # имена таблиц, с которыми ассоциированна форма

Kadry.

Ceh.

ATTRIBUTES # Имена экранных полей в форме и их атрибуты.

# слева от знака (=) пишется метка поля (которая фигурирует в

# разделе SCREEN), справа - имя экранного поля, которое обычно,

# для удобства, должно совпадать с именем какого-нибудь столбца

# из таблиц, перечисленных в разделе TABLES.

Nceh = kadry.nomerceh;

F002 = zarplata, COLOR=REVERSE WHERE f002 >500;

# если в поле выведено значение больше 500, то оно будет

# выделено с атрибутом REVERSЕ (негатив).

Fio = fio;

Dol = dolvn, comments="Проверьте наличие в штатном расписании";

S1 = ceh.nomerceh;

S2 = ceh.nameceh;

# здесь экранные поля можно

INSTRUCTIONS # объединить в экранные записи

Screen record kad (kadry.nomerceh, dolvn, zarplata).

# и описать экранные массивы

Screen record scr[3] (ceh.nomerceh, nameceh).

END.

а вот что увидит на экране пользователь, использующий эту форму:

ѓ'ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ'

ѓљ номер цеха [ ] зарплата [f002 ] ѓљ

ѓљ фамилия [ ] ѓљ

ѓљ должность [ ] ѓљ

ѓљ Так в экранной форме рисуется рамка. ѓљ

ѓљ Значок используется для входа и выхода в графический режим ѓљ

ѓљ ѓ'ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ'

ѓљ ѓљ Экранный массив ѓљ ѓљ

ѓљ ѓљ [ ] [ ] ѓљ ѓљ

ѓљ ѓљ [ ] [ ] ѓљ ѓљ

ѓљ ѓљ [ ] [ ] ѓљ ѓљ

ѓљ ѓљ номер цеха название цеха ѓљ ѓљ

ѓљ ѓ"ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ".

ѓљ в графическом режиме символы р q b d - | заменяются ѓљ

ѓљ символами рисования рамки ѓ' ѓ' ѓ" ѓ" ѓ› ѓљ ѓљ

ѓ"ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ›ѓ

В этой экранной форме определены экранные поля: kadry.nomerceh, zarpllatа, fiо, dolvп, ceh.nomerceh, nameceh А так же экранные записи: kadrу (по умолчанию), ceh (по умолчанию), kad, scr[3].

©Drkb::03004.

Извлечение данных индекса таблицы

Получить во время выполнения приложения список индексов, ассоциированных с таблицей также просто, как вызвать метод GetIndexNames для компонентов TTable, TQuery или TStoredProc. Метод GetIndexNames возвращает список, доступный в наборе данных для компонента TStrignList, установленного на форме (для нашего примера), или других визуальных компонентов, таких как TListBox, через свойство Items:

Code: ListBox1.Clear; Table1.GetIndexNames(ListBox1.Items);

Извлечение иконки из EXE, DLL или ICO-файла

Функция SHELLAPI ExtractIconEx:

Code: Обратите внимание - в примере функции обьявленны иначе, чем в модуле ShellAPI. Type ThIconArray = array[0..0] of hIcon; Type PhIconArray = ^ThIconArray; Function ExtractIconExA(lpszFile: PAnsiChar; NIconIndex: Integer; PhiconLarge : PhIconArray; PhiconSmall: PhIconArray; NIcons: UINT): UINT; stdcall; External 'shell32.dll' name 'ExtractIconExA'; Function ExtractIconExW(lpszFile: PWideChar; NIconIndex: Integer; PhiconLarge: PhIconArray; PhiconSmall: PhIconArray; NIcons: UINT): UINT; stdcall; External 'shell32.dll' name 'ExtractIconExW'; Function ExtractIconEx(lpszFile: PAnsiChar; NIconIndex: Integer; PhiconLarge : PhIconArray; PhiconSmall: PhIconArray; NIcons: UINT): UINT; stdcall; External 'shell32.dll' name 'ExtractIconExA'; Procedure TForm1.Button1Click(Sender: TObject); Var. NumIcons : integer; PTheLargeIcons : phIconArray; PTheSmallIcons : phIconArray; LargeIconWidth : integer; SmallIconWidth : integer; SmallIconHeight : integer; I : integer; TheIcon : TIcon; TheBitmap : TBitmap; Begin. NumIcons := ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe', -1, Nil, Nil, 0); If NumIcons > 0 then begin. LargeIconWidth := GetSystemMetrics(SM_CXICON); SmallIconWidth := GetSystemMetrics(SM_CXSMICON); SmallIconHeight := GetSystemMetrics(SM_CYSMICON); GetMem(pTheLargeIcons, NumIcons * sizeof(hIcon)); GetMem(pTheSmallIcons, NumIcons * sizeof(hIcon)); FillChar(pTheLargeIcons^, NumIcons * sizeof(hIcon), #0); FillChar(pTheSmallIcons^, NumIcons * sizeof(hIcon), #0); ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe', 0, PTheLargeIcons, PTheSmallIcons, NumIcons); {$IFOPT R+}. {$DEFINE CKRANGE}. {$R-}. {$ENDIF}. For i := 0 to (NumIcons - 1) do begin. DrawIcon(Form1.Canvas.Handle, I * LargeIconWidth, 0, PTheLargeIcons^[i]); TheIcon := TIcon. Create; TheBitmap := TBitmap.Create; TheIcon.Handle := pTheSmallIcons^[i]; TheBitmap.Width := TheIcon.Width; TheBitmap.Height := TheIcon.Height; TheBitmap.Canvas.Draw(0, 0, TheIcon); TheIcon.Free; Form1.Canvas.StretchDraw(Rect(i * SmallIconWidth, 100, (i + 1) * SmallIconWidth, 100 + SmallIconHeight), TheBitmap); TheBitmap.Free; End; {$IFDEF CKRANGE}. {$UNDEF CKRANGE}. {$R+}. {$ENDIF}. FreeMem(pTheLargeIcons, NumIcons * sizeof(hIcon)); FreeMem(pTheSmallIcons, NumIcons * sizeof(hIcon)); End; End; End.

©Drkb::02343.

Функция ExtractIcon позволяет извлечь иконку из exe, dll и ico-файлов. Если указанная иконка отсутствует, функция возвращает 0. Количество иконок, содержащихся в файле, можно узнать, указав в качестве последнего параметра –1.

Code: Uses ShellAPI; Procedure TForm1.Button1Click(Sender: TObject); Var. Ic: TIcon; I, count: integer; W: integer; Begin. If OpenDialog1.Execute = false then. Exit; Form1.Canvas.FillRect(Form1.Canvas.ClipRect); Count := ExtractIcon(Application.Handle, PChar(OpenDialog1.FileName), -1); Ic := TIcon.Create; W := Form1.Width div 32; For i := 0 to count - 1 do. Begin. Ic.Handle := ExtractIcon(Application.Handle, PChar(OpenDialog1.FileName), i); Form1.Canvas.Draw(32 * (i mod w), 32 * (i div w), ic); End; Ic.Destroy; End;

©Drkb::02344.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Извлечь основную иконку EXE-файла :

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Icon: TIcon; FileInfo: SHFILEINFO; Begin. Icon := TIcon.Create; Try. // Get the Icon. SHGetFileInfo(PChar('Filename.exe'), 0, FileInfo, SizeOf(FileInfo), SHGFI_ICON); Icon.Handle := FileInfo.hIcon; DestroyIcon(FileInfo.hIcon); // Save the Icon to a file: Icon.SaveToFile('IconFromExe.ico'); // Set the Icon as Application Icon (temporary). Application.Icon := icon; Finally. Icon.Free; End; End;

©Drkb::02345.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Процесс получения иконок из .EXE, .DLL или .ICO файлов полностью идентичен. Различие только в том, что в .ICO файле может храниться только одна иконка, а в .EXE и .DLL несколько. Для получения иконок из файлов, в модуле ShellAPI, есть функция:

Code: Function ExtractIcon(Inst: THandle; FileName: PChar; IconIndex: Word): HIcon;

Где.

Inst.

Указатель на приложение вызвавшее функцию,

FileName.

Имя файла из которого необходимо получить иконку,

IconIndex.

Номер необходимой иконки.

Если функция возвращает значение не равное нулю, то в файле есть следующая иконка.

В данном примере в компонент Image1 выводится иконка запущенного файла.

Code: Uses ShellAPI; ... Procedure TForm1.FormCreate(Sender: TObject); Var. A: array [0..78] of Char; Begin. {Получение имени запущенного файла}. StrPCopy(A, ParamStr(0)); {Вывод на экран нулевой иконки из файла}. Image1.Picture.Icon.Handle := ExtractIcon(HInstance, A, 0); End;

Если вы хотите создать некий браузер по иконкам, то можете воспользоваться компонентами с закладки Win3.1. Вынесите на форму компонент TFileListBox; затем TDirectoryListBox, в свойстве FileList укажите на список файлов [TFileListBox]; после этого возьмите компонент класса TDriveComboBox, указав в его свойстве DirList на список каталогов [TDirectoryListBox], ну, и, наконец, ставьте TFilterComboBox, который позволит в списке файлов отображать только те файлы, которые соответствуют маске, указанной в свойстве Filter. Здесь в качестве значения укажите следующее: ico|*.ico|dll|*.dll|exe|*.exe|all|*.ico; *.dll; *.exe ..а в свойстве FileList задайте список файлов [TFileListBox]. В обработчике OnClick компонента TFileListBox напишите такой код:

Code: Var. A: array [0..78] of Char; Begin. {Получение имени файла, указанного в списке файлов}. StrPCopy(A, FileListBox1.FileName); {Вывод на экран нулевой иконки из файла}. Image1.Picture.Icon.Handle := ExtractIcon(HInstance, A, 0);

©Drkb::02346.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Эффект разбрызгивания (Spray).

Code: Procedure Spray(Canvas: TCanvas; x, y, r: Integer; Color: TColor); Var. Rad, a: Single; I: Integer; Begin. For i := 0 to 100 do. Begin. A := Random * 2 * pi; Rad := Random * r; Canvas.Pixels[x + Round(rad * Cos(a)), y + Round(rad * Sin(a))] := Color; End; End; Procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Begin. If ssLeft in Shift then Spray(Image1.Canvas, x, y, 40, clRed); End; Procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Begin. If ssLeft in Shift then Spray(Image1.Canvas, x, y, 40, clRed); End;

Изменение гаммы рисунка.

Изменение гаммы рисунка

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Изменение гаммы рисунка. Зависимости: Graphics. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Автор Федоровских Николай. Дата: 5 июня 2002 г. ***************************************************** } Procedure Gamma(Bitmap: TBitmap; L: Double); {0.0 < L < 7.0}. Function Power(Base, Exponent: Extended): Extended; Begin. Result := Exp(Exponent * Ln(Base)); End; Type. TRGB = record. B, G, R: Byte; End; PRGB = ^TRGB; Var. Dest: pRGB; X, Y: Word; GT: array[0..255] of Byte; Begin. Bitmap.PixelFormat := pf24Bit; GT[0] := 0; If L = 0 then. L := 0.01; For X := 1 to 255 do. GT[X] := Round(255 * Power(X / 255, 1 / L)); For Y := 0 to Bitmap.Height - 1 do. Begin. Dest := Bitmap.ScanLine[y]; For X := 0 to Bitmap.Width - 1 do. Begin. With Dest^ do. Begin. R := GT[R]; G := GT[G]; B := GT[B]; End; Inc(Dest); End; End; End;

©Drkb::03854.

Изменение размера

Code: { This function resizes a bitmap calculating the average color of a rectangular. Area of pixels from source bitmap to a pixel or a rectangular area to target. Bitmap. It produces a soft-color and undistorsioned result image unlike the StretchDraw. Method. I think that this method have a tenichal name, but I am not sure. As you can see, this function could be very optimized :p. } Procedure TFormConvertir.ResizeBitmap(imgo, imgd: TBitmap; nw, nh: Integer); Var. Xini, xfi, yini, yfi, saltx, salty: single; X, y, px, py, tpix: integer; PixelColor: TColor; R, g, b: longint; Function MyRound(const X: Double): Integer; Begin. Result := Trunc(x); If Frac(x) >= 0.5 then. If x >= 0 then Result := Result + 1. Else. Result := Result - 1; // Result := Trunc(X + (-2 * Ord(X < 0) + 1) * 0.5); End; Begin. // Set target size. Imgd.Width := nw; Imgd.Height := nh; // Calcs width & height of every area of pixels of the source bitmap. Saltx := imgo.Width / nw; Salty := imgo.Height / nh; Yfi := 0; For y := 0 to nh - 1 do. Begin. // Set the initial and final Y coordinate of a pixel area. Yini := yfi; Yfi := yini + salty; If yfi >= imgo.Height then yfi := imgo.Height - 1; Xfi := 0; For x := 0 to nw - 1 do. Begin. // Set the inital and final X coordinate of a pixel area. Xini := xfi; Xfi := xini + saltx; If xfi >= imgo.Width then xfi := imgo.Width - 1; // This loop calcs del average result color of a pixel area. // of the imaginary grid. R := 0; G := 0; B := 0; Tpix := 0; For py := MyRound(yini) to MyRound(yfi) do. Begin. For px := MyRound(xini) to MyRound(xfi) do. Begin. Inc(tpix); PixelColor := ColorToRGB(imgo.Canvas.Pixels[px, py]); R := r + GetRValue(PixelColor); G := g + GetGValue(PixelColor); B := b + GetBValue(PixelColor); End; End; // Draws the result pixel. Imgd.Canvas.Pixels[x, y] := Rgb(MyRound(r / tpix), MyRound(g / tpix), MyRound(b / tpix). ); End; End; End;

Изменение вида сортировки объектов в диалогах.

Изменение вида сортировки объектов в диалогах

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). SaveDialog1: TSaveDialog; Button1: TButton; Procedure SaveDialog1Show(Sender: TObject); Procedure Button1Click(Sender: TObject); Private. { Private declarations }. Public. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. // Стили: $7029 - значки, $702B - список, $702C - таблица, $702D - эскизы, $702E - плитка. // ставим, например таблицу. Function NewSaveDlgProc(wnd:HWND; uMsg:integer; wParam:integer; lParam:integer):integer; stdcall; Begin. If uMsg=WM_SHOWWINDOW then. Begin. MoveWindow(wnd, 10, 30, 500, 300, True) ; SendMessage(FindWindowEx(wnd, 0, 'SHELLDLL_DefView', nil), WM_COMMAND, $702C, 0); End; Result:=CallWindowProc(Pointer(GetWindowLong(wnd,GWL_USERDATA)),wnd,uMsg,wParam,lParam). End; Procedure TForm1.SaveDialog1Show(Sender: TObject); Begin. SetWindowLong(GetParent(SaveDialog1.Handle),GWL_USERDATA, SetWindowLong(GetParent(SaveDialog1.Handle),DWL_DLGPROC,DWORD(@NewSaveDlgProc))); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. SaveDialog1.Execute. End; End.

Автор: Krid.

Взято из http://forum.sources.ru.

©Drkb::01218.

Изменение глубины цвета изображения.

Изменение глубины цвета изображения

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Button1: TButton; Procedure Button1Click(Sender: TObject); Public. Function ChangeColorDepth(const FromBMP: TBitmap; out ToBMP: TBitmap; Const ColorDepth: TPixelFormat): Boolean; End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.Button1Click(Sender: TObject); Var. B24, B16: TBitmap; Begin. B24 := TBitmap.Create; Try. B24.LoadFromFile('c:\1.bmp'); If ChangeColorDepth(B24, B16, pf4bit) then. Try. B16.SaveToFile('c:\2.bmp'); Finally. B16.Free; End; Finally. B24.Free; End; End; Function TForm1.ChangeColorDepth(const FromBMP: TBitmap; Out ToBMP: TBitmap; const ColorDepth: TPixelFormat): Boolean; Begin. Result := True; Try. ToBMP := TBitmap.Create; ToBMP.Width := FromBMP.Width; ToBMP.Height := FromBMP.Height; ToBMP.PixelFormat := ColorDepth; ToBMP.Canvas.Draw(0, 0, FromBMP); Except. If ToBMP <> nil then ToBMP.Free; Result := False; End; End; End.

Взято из http://forum.sources.ru.

Автор: Rouse_

©Drkb::03713.

Изменение громкости в TMediaPlayer.

Изменение громкости в TMediaPlayer.

Code: Unit MpVolume; Interface. Uses Windows, MPlayer; Const. MCI_SETAUDIO = $0873; MCI_DGV_SETAUDIO_VOLUME = $4002; MCI_DGV_SETAUDIO_ITEM = $00800000; MCI_DGV_SETAUDIO_VALUE = $01000000; MCI_DGV_STATUS_VOLUME = $4019; Type. MCI_DGV_SETAUDIO_PARMS = record. DwCallback: DWORD; DwItem: DWORd; DwValue: DWORD; DwOver: DWORD; LpstrAlgorithm: PChar; LpstrQuality: PChar; End; Type. MCI_STATUS_PARMS = record. DwCallback: DWORD; DwReturn: DWORD; DwItem: DWORD; DwTrack: DWORD; End; //Remember to add the name of your form to the procedures. Function GetMPVolume(MP: TMediaPlayer): Integer; Procedure SetMPVolume(MP: TMediaPlayer; Volume: Integer); Implementation. Uses mmsystem; Function GetMPVolume(MP: TMediaPlayer): Integer; Var. P: MCI_STATUS_PARMS; Begin. P.dwCallback := 0; P.dwItem := MCI_DGV_STATUS_VOLUME; MciSendCommand(MP.DeviceID, MCI_STATUS, MCI_STATUS_ITEM, Cardinal(@p)); Result := p.dwReturn; { Volume: 0 - 1000 }. End; Procedure SetMPVolume(MP: TMediaPlayer; Volume: Integer); Var. P: MCI_DGV_SETAUDIO_PARMS; Begin. { Volume: 0 - 1000 }. P.dwCallback := 0; P.dwItem := MCI_DGV_SETAUDIO_VOLUME; P.dwValue := Volume; P.dwOver := 0; P.lpstrAlgorithm := nil; P.lpstrQuality := nil; MciSendCommand(MP.DeviceID, MCI_SETAUDIO, MCI_DGV_SETAUDIO_VALUE or MCI_DGV_SETAUDIO_ITEM, Cardinal(@p)); End; End.

Автор: Smike.

Взято из http://forum.sources.ru.

©Drkb::03621.

Изменение иконки приложения

Присвойте свойству Application.Icon другую иконку и вызовите функцию

Изменение контрастности изображения.

Изменение контрастности изображения

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Изменение контрастности изображения. Value - значение контрастности на отрезке [-100..100]. Local - если True, то применяется "местный контраст", Если False, то - "общий" (более красивый). Зависимости: Windows. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Николай Федоровских. Дата: 14 июля 2003 г. ***************************************************** } Procedure Contrast(Bitmap: TBitmap; Value: Integer; Local: Boolean); Function BLimit(B: Integer): Byte; Begin. If B < 0 then. Result := 0. Else if B > 255 then. Result := 255. Else. Result := B; End; Var. Dest: pRGBTriple; X, y, mr, mg, mb, W, H, tr, tg, tb: Integer; Vd: Double; Begin. If Value = 0 then. Exit; W := Bitmap.Width - 1; H := Bitmap.Height - 1; If Local then. Begin. MR := 128; MG := 128; MB := 128; End. Else. Begin. Tr := 0; Tg := 0; Tb := 0; For y := 0 to H do. Begin. Dest := Bitmap.ScanLine[y]; For x := 0 to W do. Begin. With Dest^ do. Begin. Inc(tb, rgbtBlue); Inc(tg, rgbtGreen); Inc(tr, rgbtRed); End; Inc(Dest); End; End; MB := Trunc(tb / (W * H)); MG := Trunc(tg / (W * H)); MR := Trunc(tr / (W * H)); End; If Value > 0 then. Vd := 1 + (Value / 10). Else. Vd := 1 - (Sqrt(-Value) / 10); For y := 0 to H do. Begin. Dest := Bitmap.ScanLine[y]; For x := 0 to W do. Begin. With Dest^ do. Begin. RgbtBlue := BLimit(mB + Trunc((rgbtBlue - mB) * vd)); RgbtGreen := BLimit(mG + Trunc((rgbtGreen - mG) * vd)); RgbtRed := BLimit(mR + Trunc((rgbtRed - mR) * vd)); End; Inc(Dest); End; End; End;

©Drkb::03855.

Изменяем цвет TPageControl.

Code: Type. TTabSheet = class(ComCtrls.TTabSheet). Private. FColor: TColor; Procedure SetColor(Value: TColor); Procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd); Message WM_ERASEBKGND; Public. Constructor Create(aOwner: TComponent); override; Property Color: TColor read FColor write SetColor; End; {...} Implementation. {...} Constructor TTabSheet.Create(aOwner: TComponent); Begin. Inherited; FColor := clBtnFace; End; Procedure TTabSheet.SetColor(Value: TColor); Begin. If FColor Value then. Begin. FColor := Value; Invalidate; End; End; Procedure TTabSheet.WMEraseBkGnd(var Msg: TWMEraseBkGnd); Begin. If FColor = clBtnFace then. Inherited. Else. Begin. Brush.Color := FColor; Windows.FillRect(Msg.dc, ClientRect, Brush.Handle); Msg.Result := 1; End; End; Procedure TForm1.FormCreate(Sender: TObject); Begin. Tabsheet1.Color := clWhite; TabSheet2.Color := clLime; End; // PageControl1.OwnerDraw := true ! Procedure TForm1.PageControl1DrawTab(Control: TCustomTabControl; TabIndex: Integer; const Rect: TRect; Active: Boolean); Var. AText: string; APoint: TPoint; Begin. With (Control as TPageControl).Canvas do. Begin. Brush.Color := clred; FillRect(Rect); AText := TPageControl(Control).Pages[TabIndex].Caption; With Control.Canvas do. Begin. APoint.x := (Rect.Right - Rect.Left) div 2 - TextWidth(AText) div 2; APoint.y := (Rect.Bottom - Rect.Top) div 2 - TextHeight(AText) div 2; TextRect(Rect, Rect.Left + APoint.x, Rect.Top + APoint.y, AText); End; End; End;

Изменить режим координат

Code: { Copyright © 1999 by Delphi 5 Developer's Guide - Xavier Pacheco and Steve Teixeira. } Unit MainFrm; Interface. Uses. SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, Menus, DB, DBCGrids, DBTables; Type. TMainForm = class(TForm). MmMain: TMainMenu; MmiMappingMode: TMenuItem; MmiMM_ISOTROPIC: TMenuItem; MmiMM_ANSITROPIC: TMenuItem; MmiMM_LOENGLISH: TMenuItem; MmiMM_HIINGLISH: TMenuItem; MmiMM_LOMETRIC: TMenuItem; MmiMM_HIMETRIC: TMenuItem; Procedure FormCreate(Sender: TObject); Procedure mmiMM_ISOTROPICClick(Sender: TObject); Procedure mmiMM_ANSITROPICClick(Sender: TObject); Procedure mmiMM_LOENGLISHClick(Sender: TObject); Procedure mmiMM_HIINGLISHClick(Sender: TObject); Procedure mmiMM_LOMETRICClick(Sender: TObject); Procedure mmiMM_HIMETRICClick(Sender: TObject); Public. MappingMode: Integer; Procedure ClearCanvas; Procedure DrawMapMode(Sender: TObject); End; Var. MainForm: TMainForm; Implementation. {$R *.DFM}. Procedure TMainForm.ClearCanvas; Begin. With Canvas do. Begin. Brush.Style := bsSolid; Brush.Color := clWhite; FillRect(ClipRect); End; End; Procedure TMainForm.DrawMapMode(Sender: TObject); Var. PrevMapMode: Integer; Begin. ClearCanvas; Canvas.TextOut(0, 0, (Sender as TMenuItem).Caption); // Set mapping mode to MM_LOENGLISH and save the previous mapping mode. PrevMapMode := SetMapMode(Canvas.Handle, MappingMode); Try. // Set the viewport org to left, bottom. SetViewPortOrgEx(Canvas.Handle, 0, ClientHeight, nil); { Draw some shapes to illustrate drawing shapes with different. Mapping modes specified by MappingMode }. Canvas.Rectangle(0, 0, 200, 200); Canvas.Rectangle(200, 200, 400, 400); Canvas.Ellipse(200, 200, 400, 400); Canvas.MoveTo(0, 0); Canvas.LineTo(400, 400); Canvas.MoveTo(0, 200); Canvas.LineTo(200, 0); Finally. // Restore previous mapping mode. SetMapMode(Canvas.Handle, PrevMapMode); End; End; Procedure TMainForm.FormCreate(Sender: TObject); Begin. MappingMode := MM_TEXT; End; Procedure TMainForm.mmiMM_ISOTROPICClick(Sender: TObject); Var. PrevMapMode: Integer; Begin. ClearCanvas; // Set mapping mode to MM_ISOTROPIC and save the previous mapping mode. PrevMapMode := SetMapMode(Canvas.Handle, MM_ISOTROPIC); Try. // Set the window extent to 500 x 500. SetWindowExtEx(Canvas.Handle, 500, 500, nil); // Set the Viewport extent to the Window's client area. SetViewportExtEx(Canvas.Handle, ClientWidth, ClientHeight, nil); // Set the ViewPortOrg to the center of the client area. SetViewportOrgEx(Canvas.Handle, ClientWidth div 2, ClientHeight div 2, nil); // Draw a rectangle based on current settings. Canvas.Rectangle(0, 0, 250, 250); { Set the viewport extent to a different value, and. Draw another rectangle. continue to do this three. More times so that a rectangle is draw to represent. The plane in a four-quadrant square }. SetViewportExtEx(Canvas.Handle, ClientWidth, -ClientHeight, nil); Canvas.Rectangle(0, 0, 250, 250); SetViewportExtEx(Canvas.Handle, -ClientWidth, -ClientHeight, nil); Canvas.Rectangle(0, 0, 250, 250); SetViewportExtEx(Canvas.Handle, -ClientWidth, ClientHeight, nil); Canvas.Rectangle(0, 0, 250, 250); // Draw an ellipse in the center of the client area. Canvas.Ellipse(-50, -50, 50, 50); Finally. // Restore the previous mapping mode. SetMapMode(Canvas.Handle, PrevMapMode); End; End; Procedure TMainForm.mmiMM_ANSITROPICClick(Sender: TObject); Var. PrevMapMode: Integer; Begin. ClearCanvas; // Set the mapping mode to MM_ANISOTROPIC and save the previous mapping mode. PrevMapMode := SetMapMode(Canvas.Handle, MM_ANISOTROPIC); Try. // Set the window extent to 500 x 500. SetWindowExtEx(Canvas.Handle, 500, 500, nil); // Set the Viewport extent to that of the Window's client area. SetViewportExtEx(Canvas.Handle, ClientWidth, ClientHeight, nil); // Set the ViewPortOrg to the center of the client area. SetViewportOrgEx(Canvas.Handle, ClientWidth div 2, ClientHeight div 2, nil); // Draw a rectangle based on current settings. Canvas.Rectangle(0, 0, 250, 250); { Set the viewport extent to a different value, and. Draw another rectangle. continue to do this three. More times so that a rectangle is draw to represent. The plane in a four-quadrant square }. SetViewportExtEx(Canvas.Handle, ClientWidth, -ClientHeight, nil); Canvas.Rectangle(0, 0, 250, 250); SetViewportExtEx(Canvas.Handle, -ClientWidth, -ClientHeight, nil); Canvas.Rectangle(0, 0, 250, 250); SetViewportExtEx(Canvas.Handle, -ClientWidth, ClientHeight, nil); Canvas.Rectangle(0, 0, 250, 250); // Draw an ellipse in the center of the client area. Canvas.Ellipse(-50, -50, 50, 50); Finally. //Restore the previous mapping mode. SetMapMode(Canvas.Handle, PrevMapMode); End; End; Procedure TMainForm.mmiMM_LOENGLISHClick(Sender: TObject); Begin. MappingMode := MM_LOENGLISH; DrawMapMode(Sender); End; Procedure TMainForm.mmiMM_HIINGLISHClick(Sender: TObject); Begin. MappingMode := MM_HIENGLISH; DrawMapMode(Sender); End; Procedure TMainForm.mmiMM_LOMETRICClick(Sender: TObject); Begin. MappingMode := MM_LOMETRIC; DrawMapMode(Sender); End; Procedure TMainForm.mmiMM_HIMETRICClick(Sender: TObject); Begin. MappingMode := MM_HIMETRIC; DrawMapMode(Sender); End; End.

Изменить размер кнопки ПУСК

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. MoveWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), 300, 0, 80, 22, true); End;

Изменить вид каретки TEdit.

В примере показано как создать два цветных "bitmap'а": "улыбчивый" и "хмурый" и присвоить их курсору edit'а. Для этого нужно перехватить оконную процедуру edit'а. Чтобы сделать это заменим адрес оконной процедуры Edit'а нашим собственным, а старую оконную процедуру будем вызывать по необходимости. Пример показывает "улыбчивый" курсор при наборе текста и "хмурый" при забое клавишей backspace.

Изменить шрифт TStatusBar.

Code: { To use this example, you need a TStatusBar and at least one Panel. Then change the style of StatusBar1.Panels[0] to. PsOwnerDraw and add the code below to the OnDrawPanel handler. } Procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); Var. SomeText: string; Begin. If Panel = StatusBar1.Panels[0] then. Begin. SomeText := 'Hello!'; Panel.Width := Trunc(StatusBar1.Canvas.TextWidth(SomeText) * 1.5); With StatusBar.Canvas do. Begin. Brush.Color := clWhite; FillRect(Rect); Font.Name := 'Arial'; Font.Color := clRed; Font.Style := Font.Style + [fsItalic, fsBold]; TextRect(Rect, Rect.Left + 1, Rect.Top, SomeText); End; End; End;

Изменить свойства системы

Когда вы вызываете контекстное меню на иконке "Моего компьютера" и щёлкаете на команде "Свойства" - вы видите свойства системы. Эта статья позволит вам внести туда любой свой собственный текст и даже поместить рисунок!

Изменить цветовые каналы битового изображения

Code: {+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Mit dem folgenden Code kann die Werte der einzelnen Farbkanale. (Rot, Grun, Blau) verandern. So lassen sich leicht fantastische Effekte erzielen. Parameter: - Bitmap: TBitmap. Erwartet ein TBitmap auf dem die Anderungen. Vollzogen werden sollen. - Red: Integer. Erwartet einen Integer der den neuen Farbwert bestimmt. Der Wert wird zu dem alten Farbwert addiert. Betragt der Wert 0, wird keine Anderung am Farbkanal. Vorgenommen. - Green: Integer; Erwartet einen Integer der den neuen Farbwert bestimmt. Der Wert wird zu dem alten Farbwert addiert. Betragt der Wert 0, wird keine Anderung am Farbkanal. Vorgenommen. - Blue: Integer; Erwartet einen Integer der den neuen Farbwert bestimmt. Der Wert wird zu dem alten Farbwert addiert. Betragt der Wert 0, wird keine Anderung am Farbkanal. Vorgenommen. ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ The following Code allows you to change the value of the. RGB-Colorchannels (Red, Green, Blue). So you can simply create fantastic effects on your pictures. Parameters: - Bitmap: TBitmap. Needs a TBitmap with a picture to read the old values. And draw the changes. - Red: Integer. A Integer which set the new value of the Color-channel. The value will be add to the old value. If the value is 0, there will be no change in the. Color-channel. - Green: Integer; A Integer which set the new value of the Color-channel. The value will be add to the old value. If the value is 0, there will be no change in the. Color-channel. - Blue: integer; A Integer which set the new value of the Color-channel. The value will be add to the old value. If the value is 0, there will be no change in the. Color-channel. ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Saturday, 2002-09-07. ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ } Function SetRGBChannelValue(Bitmap: TBitmap; Red, Green, Blue: Integer): Boolean; Var. I, j: Integer; Rgbc: array[0..2] of Byte; C: TColor; R, g, b: Byte; Begin. //Wenn keine Anderungen vorgenommen werden, Vorgang beenden: //If there is no change, exit: If (Red = 0) and (Green = 0) and (Blue = 0) then. Begin. Result := False; Exit; End; For i := 0 to Bitmap.Height do. Begin. For j := 0 to Bitmap.Width do. Begin. // Get the old Color. C := Bitmap.Canvas.Pixels[j, i]; // Splitt the old color into the different colors: Rgbc[0] := GetRValue(c); Rgbc[1] := GetGValue(c); Rgbc[2] := GetBValue(c); //Check that there is no "new" color while the addition. //of the values: If not (rgbc[0] + Red < 0) and not (rgbc[0] + Red > 255) then. Rgbc[0] := rgbc[0] + Red; If not (rgbc[1] + Green < 0) and not (rgbc[1] + Green > 255) then. Rgbc[1] := rgbc[1] + Green; If not (rgbc[2] + Blue < 0) and not (rgbc[2] + Blue > 255) then. Rgbc[2] := rgbc[2] + Blue; R := rgbc[0]; G := rgbc[1]; B := rgbc[2]; //set the new color back to the picture: Bitmap.Canvas.Pixels[j, i] := RGB(r, g, b); End; End; Result := True; End; //Beispiel, wie man die Funktion benutzen kann: //Example, how to use it: Procedure TForm1.Button1Click(Sender: TObject); Begin. SetColorValue(Image1.picture.Bitmap, Spinedit1.Value, Spinedit2.Value, Spinedit3.Value); End;

©Drkb::03872.

Взято с сайта: http://www.swissdelphicenter.ch.

Изменить цвет выделения для TRichEdit.

Code: Uses. RichEdit; Procedure RE_SetSelBgColor(RichEdit: TRichEdit; AColor: TColor); Var. Format: CHARFORMAT2; Begin. FillChar(Format, SizeOf(Format), 0); With Format do. Begin. CbSize := SizeOf(Format); DwMask := CFM_BACKCOLOR; CrBackColor := AColor; Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format)); End; End; // Example: Set clYellow background color for the selected text. Procedure TForm1.Button1Click(Sender: TObject); Begin. RE_SetSelBgColor(RichEdit1, clYellow); End;

Изменить цвет неактивного TEdit.

Code: {Question: How can I change the color of a disabled (Edit1.Enabled := false;) control? I do not want the normal grey color. Answer: Two options: 1) place the control on a panel and disable the panel instead of the control. This way the color stays to whatever you set it. 2) make a descendent and take over the painting when it is disabled. Here is an example:}. Unit PBExEdit; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TPBExEdit = class(TEdit). Private. { Private declarations }. FDisabledColor: TColor; FDisabledTextColor: TColor; Procedure WMPaint(var msg: TWMPaint); message WM_PAINT; Procedure WMEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND; Procedure SetDisabledColor(const Value: TColor); virtual; Procedure SetDisabledTextColor(const Value: TColor); virtual; Protected. { Protected declarations }. Public. { Public declarations }. Constructor Create(aOwner: TComponent); override; Published. { Published declarations }. Property DisabledTextColor: TColor read FDisabledTextColor. Write SetDisabledTextColor default clGrayText; Property DisabledColor: TColor read FDisabledColor. Write SetDisabledColor default clWindow; End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('PBGoodies', [TPBExEdit]); End; Constructor TPBExEdit.Create(aOwner: TComponent); Begin. Inherited; FDisabledColor := clWindow; FDisabledTextColor := clGrayText; End; Procedure TPBExEdit.SetDisabledColor(const Value: TColor); Begin. If FDisabledColor <> Value then. Begin. FDisabledColor := Value; If not Enabled then. Invalidate; End; End; Procedure TPBExEdit.SetDisabledTextColor(const Value: TColor); Begin. If FDisabledTextColor <> Value then. Begin. FDisabledTextColor := Value; If not Enabled then. Invalidate; End; End; Procedure TPBExEdit.WMEraseBkGnd(var msg: TWMEraseBkGnd); Var. Canvas: TCanvas; Begin. If Enabled then. Inherited. Else. Begin. Canvas:= TCanvas.Create; Try. Canvas.Handle := msg.DC; SaveDC(msg.DC); Try. Canvas.Brush.Color := FDisabledColor; Canvas.Brush.Style := bsSolid; Canvas.Fillrect(clientrect); Msg.Result := 1; Finally. RestoreDC(msg.DC, - 1); End; Finally. Canvas.free. End; End; End; Procedure TPBExEdit.WMPaint(var msg: TWMPaint); Var. Canvas: TCanvas; Ps: TPaintStruct; CallEndPaint: Boolean; Begin. If Enabled then. Inherited. Else. Begin. CallEndPaint := False; Canvas:= TCanvas.Create; Try. If msg.DC <> 0 then. Begin. Canvas.Handle := msg.DC; Ps.fErase := true; End. Else. Begin. BeginPaint(Handle, ps); CallEndPaint:= True; Canvas.handle := ps.hdc; End; If ps.fErase then. Perform(WM_ERASEBKGND, Canvas.Handle, 0); SaveDC(canvas.handle); Try. Canvas.Brush.Style := bsClear; Canvas.Font := Font; Canvas.Font.Color := FDisabledTextColor; Canvas.TextOut(1, 1, Text); Finally. RestoreDC(Canvas.Handle, - 1); End; Finally. If CallEndPaint then. EndPaint(handle, ps); Canvas.Free. End; End; End; End.

Изменить экранный курсор без необходимости возвращать предыдущий

Code: // By implementing Interface we can set the cursor without restore it in the end. // Example: In convensional way... Var. Cur: TCursor; Begin. Cur := Screen.Cursor; Screen.Cursor := crSQLWait; //do coding here. //What happend is that if your code did not finish, the screen cursor will. //remain as crSQLWait.. even with try..finally block (sometimes). Screen.Cursor := Cur; End; // By using interface, we can implement as follows. Type. ImyCursor = interface. [(GUID - Ctrl - Shift - G)]. End; TmyCursor = class(TInterfacedObjects, ImyCursor); Private. FCursor: TCursor; Public. Constructor Create; Destructor Destroy; override; End; Implementation. TmyCursor.Create; Begin. FCursor := Screen.Cursor; End; TmyCursor.Destroy; Begin. Screen.Cursor := FCursor; Inherited; End; Procedure....var. C: ImyCursor; Begin. C := TmyCursor.Create; Screen.Curosr := crSQLWait; // whatever cursor you like. // Do coding here without worring to free it. // Screen Cursor will restore when the TMyCursor object get out of scope. End;

Изучаем DelphiX (Часть 1).

Изучаем DelphiX.

Изучаем DelphiX (Часть 2).

Изучаем DelphiX (Часть 2).

Изучаем DelphiX. Часть 2: Усложняем нашу игру.

Автор: Влад Энгельгардт

Хех! загружу:".

Прежде чем начать, объясню решение Д/З:

1. Сделайте так, чтобы при уходе патрона из зоны видимости он уничтожался:

Это очень легко сделать достаточно в процедуру DoMove патрона вставить:

Code: If y<= 0 then Dead; If y>= 600 then Dead;

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

2. Сделайте, чтобы патроны стреляли очередями, а не кучами как у меня:

Вот эта задача была посложнее первой. Во-первых, как я сделал в первой части этого туториала, делать нельзя из-за причины небольшой "кривости" DelphiX, он может держать только определённое количество спрайтов, а если их больше он или выходит или подвисает. Так что, делаем вот так:

В класс с плеером добавляем две переменные, он теперь выглядит так (я добавил комментарии к тем строчкам которые изменились):

Code: TPlayerSprite = class(TImageSprite). Private. Lngpolet:integer; //расстояние которое пролетела пуля. Oldlngpolet:integer; //расстояние которое пролетела предыдущая пуля. Protected. Procedure DoMove(MoveCount: Integer); override; End;

Процедура DoMove класса PlayerSprite изменяется следующим образом:

Code: Procedure TPlayerSprite.DoMove(MoveCount: Integer); Begin. Inherited DoMove(MoveCount); If isLeft in Form1.DXInput1.States then x:=x-5; If isRight in Form1.DXInput1.States then X:=x+5; If isup in Form1.DXInput1.States then. Begin. If lngpolet-oldlngpolet>=250 then // Если расстояние между пулями меньше 250, // то пуля не создаётся. Begin. Inc(lngpolet); With TPlayerFa.Create(Engine) do. Begin. PixelCheck := True; Image := form1.dxImageList1.Items.Find('Pula'); X := Self.X+Self.Width -40; Y := Self.Y+Self.Height -80; Width := Image.Width; Height := Image.Height; End; Oldlngpolet := lngpolet; //после создания пули - последняя становится первой. End; End; If y >= form1.DXDraw1.SurfaceHeight-image.Height then. Y := form1.DXDraw1.SurfaceHeight-image.Height; If x >= form1.DXDraw1.SurfaceWidth -image.Width then. X := form1.DXDraw1.SurfaceWidth -image.Width; If y <= 0 then. Y := 1; If x <= 0 then. X:=1; Lngpolet := lngpolet + MoveCount; // расстояние увеличиваем, когда пуля движется. End;

Вот и всё, что требовалось сделать.

В этой части вы узнаете: 1. Создание анимации. 2. Создание примитивного AI. 3. Создадим простенькие взрывы.

Создание анимации.

Анимация в DelphiX строится следующим образом:

Это пример покадровой анимации. У каждого кадра должен быть одинаковый размер.

В данной ситуации: Ширина: 40 Высота: 38.

Давайте теперь, применим ее к нашей игре. Идём в DXImageList, находим наш спрайт Pula и загружаем картинку с анимацией. Далее устанавливаем свойства спрайта следующим образом:

и в процедуре DoMove класса PlayerSprite изменяем код следующим образом:

Code: Procedure TPlayerSprite.DoMove(MoveCount: Integer); Begin. Inherited DoMove(MoveCount); If isLeft in Form1.DXInput1.States then x:=x-5; If isRight in Form1.DXInput1.States then X:=x+5; If isup in Form1.DXInput1.States then. Begin. If lngpolet-oldlngpolet>=250 then. Begin. Inc(lngpolet); With TPlayerFa.Create(Engine) do. Begin. PixelCheck := True; Image := form1.dxImageList1.Items.Find('Pula'); X := Self.X+Self.Width -40; Y := Self.Y+Self.Height -80; Width := Image.Width; Height := Image.Height; AnimCount := Image.PatternCount; //число кадров. AnimLooped := True; //повторять ли анимацию. AnimSpeed := 10 / 1000; //скорость анимации. End; Oldlngpolet := lngpolet; End; End; If y >= form1.DXDraw1.SurfaceHeight-image.Height then. Y := form1.DXDraw1.SurfaceHeight-image.Height; If x >= form1.DXDraw1.SurfaceWidth -image.Width then. X := form1.DXDraw1.SurfaceWidth -image.Width; If y <= 0 then. Y := 1; If x <= 0 then. X:=1; Lngpolet := lngpolet + MoveCount; End;

Можно проделать тоже самое с другими классами для придания реалистичности игры.

Cоздание примитивного AI.

Для начала маленько улучшим наш класс плеера, добавим в него столкновение, и он теперь выглядит следующим образом:

Code: TPlayerSprite = class(TImageSprite). Private. Lngpolet:integer; Oldlngpolet:integer; Protected. Procedure DoMove(MoveCount: Integer); override; //добавляем. Procedure DoCollision(Sprite: TSprite; var Done: Boolean); override; End;

Далее создаём процедуру DoCollision и вставляем в неё следующее:

Code: Procedure TPlayerSprite.DoCollision(Sprite: TSprite; var Done: Boolean); Begin. If Sprite is TPlayerFa then Dead; Collision; End;

Дальше пред implementation добавляем 1 переменную:

Code: Plx:double; //X плеера.

Далее обновим класс TPlayerFa и он станет таким:

Code: TPlayerFa = class(TImageSprite). Private. Stril:Integer; // Как вы заметили, добавилась переменная. Protected. Procedure DoCollision(Sprite: TSprite; var Done: Boolean); override; Procedure DoMove(MoveCount: Integer); override; Public. Constructor Create(AParent: TSprite); override; Destructor Destroy; override; End;

А в TPlayerFa добавляем строчку:

Code: Procedure TPlayerFa.DoMove(MoveCount: Integer); Begin. Y:=y-stril; // когда стреляет игрок, с этой скоростью будет двигаться пуля. Y:=y+stri; // когда стреляет AI, с этой скоростью будет двигаться пуля. If y<= 0 then Dead; If y>= 600 then Dead; End;

А процедура TBoSS.DoMove становиться такой:

Code: Procedure TBoSS.DoMove(MoveCount: Integer); Begin. Inherited DoMove(MoveCount); If x>= 600 then I:= false; If x<= 0 then I:= true; If i= true then X := X+5; If i= false then X := X-5; If plx=x then //если равна х плеера стреляем. Begin. With TPlayerFa.Create(Engine) do. Begin. PixelCheck := True; Image := form1.dxImageList1.Items.Find('Pula'); X := Self.X+Self.Width-70; Y := Self.Y+Self.Height+10; Width := Image.Width; Height := Image.Height; Stril:=5; //скорость патрона. End; End; Collision; End;

И естественно полнеет и TPlayerSprite:

Code: Procedure TPlayerSprite.DoMove(MoveCount: Integer); Begin. Inherited DoMove(MoveCount); Plx:=x; //чтобы наш комп видел нашего плеера. If isLeft in Form1.DXInput1.States then. Begin. X:=x-5; Plx:=x; End; If isRight in Form1.DXInput1.States then. Begin. X:=x+5; Plx:=x; End; If isup in Form1.DXInput1.States then. Begin. If lngpolet-oldlngpolet>=250 then. Begin. Inc(lngpolet); With TPlayerFa.Create(Engine) do. Begin. PixelCheck := True; Image := form1.dxImageList1.Items.Find('Pula'); X := Self.X+Self.Width -40; Y := Self.Y+Self.Height -80 ; Width := Image.Width; Height := Image.Height; Stril:=-4; End; Oldlngpolet := lngpolet; End; End; If y >= form1.DXDraw1.SurfaceHeight-image.Height then. Y := form1.DXDraw1.SurfaceHeight-image.Height; If x >= form1.DXDraw1.SurfaceWidth -image.Width then. X := form1.DXDraw1.SurfaceWidth -image.Width; If y <= 0 then. Y := 1; If x <= 0 then. X:=1; Lngpolet := lngpolet + MoveCount; Collision; End;

И поменялся конструктор PlayerFa:

Code: Constructor TPlayerFa.Create(AParent: TSprite); Begin. Inherited Create(AParent); Image := form1.DXImageList1.Items.Find('Pula'); Width := Image.Width; Height := Image.Height; AnimCount := Image.PatternCount; //число кадров. AnimLooped := True; //повторять ли анимацию. AnimSpeed:= 10 / 1000; Collision; End;

Создадим простенькие взрывы.

Для начала загрузим спрайт взрыва в DXImageList вот он:

Назовём его "ex" и установим размер кадра на 32Х48 (PatternHeight - PatternWidth).

Дальше, в класс TPlayerSprite в private добавляем procedure Hit; и создаём обработчик:

Code: Procedure TplayerSprite.Hit; Begin. Collisioned := False; Image := Form1.dxImageList1.Items.Find('Ex'); Width := Image.Width; Height := Image.Height; AnimCount := Image.PatternCount; AnimLooped := False; AnimSpeed := 15/1000; AnimPos := 0; End;

и в процедуре TPlayerSprite.DoCollision вставляем следущий код:

Code: Procedure TPlayerSprite.DoCollision(Sprite: TSprite; var Done: Boolean); Begin. If sprite is Tplayerfa then. Begin. TPlayerSprite(Sprite).Hit; Dead; End; Done := False; End;

Этот код надо разместить и в Tboss. DoCollision.

И под конец маленький бонус: Можно создать бэкграунд, без создания нового класса достаточно в FormCreate написать:

Code: With TBackgroundSprite.Create(DXSpriteEngine1.Engine) do. Begin. SetMapSize(1,1); Image := dxImageList1.Items.Find('bgr'); Z:= -2; Tile := True; End;

Где bgr спрайт-бэкграунд. Вот мой БГ:

Нравиться? Здесь можно скачать исподники всей этой части. part2.rar(77,5 kB).

Автор: Влад Энгельгардт

©Drkb::03930.

Изучаем DelphiX (Часть 3).

Изучаем DelphiX (Часть 3).

Изучаем DelphiX. Часть 3: Крутим спрайты.

Автор: Влад Энгельгардт

"Крутимся не накрутимся:)".

В DelphiX существует маленькая проблема, это разворот спрайтов. Она решается относительно просто, сейчас я объясню, как и что.

Для начала создадим новый проект в Delphi, подстроим его под шаблон (об этом написано в одной из частей цикла). Далее скачиваем мною модернизированный DXSprite.pas (Dxsprite.rar), в папке, где у вас установлен DelphiX есть папочка Source, копируем его туда. В DXSprite.pas я добавил всего одну процедуру Angle это и есть процедура разворота, как она работает можете посмотреть, сами поковырявшись в исходниках. Ну что приступим, для начала создадим простенький пример (в архиве с исходниками в папке 3.1).

Создаём новый класс:

Code: TPlayerone = class(TImageSprite). Protected. Procedure DoMove(MoveCount: Integer); override; End;

Соответственно и процедуру DoMove к этому классу:

Code: Procedure TPlayerone.DoMove(MoveCount: Integer); Begin. Inherited DoMove(MoveCount); X:=x+cos256(Angle)*speed; //обработчик движения по X. Y:=y+sin256(Angle)*speed; //обработчик движения по Y. If y >= form1.DXDraw1.SurfaceHeight-image.Height then. Y := form1.DXDraw1.SurfaceHeight-image.Height; If x >= form1.DXDraw1.SurfaceWidth -image.Width then. X := form1.DXDraw1.SurfaceWidth -image.Width; If y <= 0 then. Y := 1; If x <= 0 then. X:=1; Begin. Speed:=0; //когда ничего не делаем, скорость равна 0. If isLeft in Form1.DXInput1.States then angle:=angle-5; If isRight in Form1.DXInput1.States then angle:=angle+5; If isup in Form1.DXInput1.States then speed:=4; If isDown in Form1.DXInput1.States then speed:=-4; End; End;

И перед implementation в Var добавляем:

Code: Var. Form1: TForm1; Speed: integer; // Это у нас переменная скорости объекта.

Не забудь в DXtimer добавить:

Code: Procedure TForm1.DXTimer1Timer(Sender: TObject; LagCount: Integer); Begin. If not DXDraw1.CanDraw then exit; DXInput1.Update; DXSpriteEngine1.Move(LagCount); DXSpriteEngine1.Dead; DXDraw1.Surface.Fill(0); DXSpriteEngine1.Draw; DXDraw1.Flip; End;

И в процедуре FormCreate создаём наш спрайт:

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. With TPlayerone.Create(Dxspriteengine1.Engine) do. Begin. PixelCheck := True; Image := form1.dxImageList1.Items.Find('krut'); X:=350; Y:=250; Width := Image.Width; Height := Image.Height; End; End;

Далее в DXImageList добавляем спрайт "krut" он у меня выглядит вот так:

И всё, простейший пример с Angle готов.

Теперь давайте усложним наш пример и сделаем так что бы игрок стрелял в ту сторону куда он смотрит, для этого создаём новый класс для патрона. Выглядит он так:

Code: TPlayerFa = class(TImageSprite). Protected. Procedure DoMove(MoveCount: Integer); override; Private. Anglefa:integer; // Угол под которым летит пуля. Public. Constructor Create(AParent: TSprite); override; Destructor Destroy; override; End;

Перед implementation добавляется ещё одна переменная ang:

Code: Var. Form1: TForm1; Speed,ang: integer;

Она нужна для выноса значения Angle плеера. А зачем нужен вынос, спросишь ты, да всё очень просто, он нужен для патрона, чтобы указывать ему, под каким углом лететь т.е. под каким углом находиться плеер под таким углом и летит патрон.

Маленько модернизируем класс плеера:

Code: TPlayerone = class(TImageSprite). Private. Lngpolet:integer; // мы же не хотим, чтобы наши пули летали кучами. Oldlngpolet:integer; // а мы сделаем чтобы летали стаями :). Protected. Procedure DoMove(MoveCount: Integer); override; End;

Сразу, чтобы не забыть конструктор и деструктор для патрона:

Code: Constructor TPlayerFa.Create(AParent: TSprite); Begin. Inherited Create(AParent); Image := form1.DXImageList1.Items.Find('pul'); Width := Image.Width; Height := Image.Height; End; Destructor TPlayerFa.Destroy; Begin. Inherited Destroy; End;

Ну а теперь движение патрона:

Code: Procedure TPlayerFa.DoMove(MoveCount: Integer); Begin. Inherited DoMove(MoveCount); Angle := anglefa; X:=x+cos256(angle)*7; // цифра 7 здесь скорость патрона и изменять её надо. Y:=y+sin256(angle)*7; // пропорционально. If X>= 800 then Dead; If y>= 600 then Dead; If X<= 0 then Dead; If y<= 0 then Dead; Collision; End;

Надеюсь, ты помнишь, на прошлых уроках я рассказывал тебе об DXInput, так вот теперь нам понадобятся дополнительные кнопочки. Их значения ты можешь поменять, два раза кликнув на самом компоненте. Так вот, гляди процедуру DoMove у игрока:

Code: Procedure TPlayerone.DoMove(MoveCount: Integer); Begin. Inherited DoMove(MoveCount); Ang:=angle; // наша переменная для патрона. X:=x+cos256(Angle)*speed; Y:=y+sin256(Angle)*speed; If y >= form1.DXDraw1.SurfaceHeight-image.Height then. Y := form1.DXDraw1.SurfaceHeight-image.Height; If x >= form1.DXDraw1.SurfaceWidth -image.Width then. X := form1.DXDraw1.SurfaceWidth -image.Width; If y <= 0 then. Y := 1; If x <= 0 then. X:=1; Begin. Speed:=0; If isLeft in Form1.DXInput1.States then angle:=angle-5; If isRight in Form1.DXInput1.States then angle:=angle+5; If isup in Form1.DXInput1.States then speed:=4; If isDown in Form1.DXInput1.States then speed:=-4; If isbutton1 in Form1.DXInput1.States then. Begin. If lngpolet-oldlngpolet>=250 then. Begin. Inc(lngpolet); With TPlayerFa.Create(Engine) do. Begin. Image := form1.DXImageList1.Items.Find('pul'); X:=self.X+cos256(ang)*50; // здесь 50 расстояние патрона от плеера. Y:=self.y+sin256(ang)*50; //они должны быть пропорциональны. Anglefa:=ang; // передаём угол. Oldlngpolet := lngpolet; End; End; End; Lngpolet := lngpolet + MoveCount; End; End;

И последнее что осталось это создать спрайт "pul" в DXimageList. Он выглядит у меня вот так:

Что, устал? Ну, расслабься, если хочешь. Дальше мы сделаем следующее: 1. Добавим второго плеера 2. И научимся делать стрэйфы

Для начала установим новую раскладку в Dxinput. Для этого два раза кликнем по кампоненту Dxinput и преходим в закладку Keybord:

Сразу маленький совет: чтобы на одной кнопке у тебя не было 300 действий для каждой метки, назначай только одну кнопку.

Я выбрал такой вариант для первого игрока: Up- Num 8 Down - Num 5 Left - Num 4 Right - Num 6 Button1 - Num 0 Button2 - Num 7 Button3 - Num 9 Для второго игрока: Button4 - T Button5 -G Button6 -F Button7- H Button8 -E Button9 -R Button10 -Y.

Посмотрите на клаву и поймёте раскладку. Ну что, приступаем, для начала перед Implementation добавим ещё две переменные, только уже для второго игрока:

Code: Var. Form1: TForm1; Speed,speed2,ang,ang2: integer; Implementation. Теперь соответственно добавляем 2 игрока и модернизируем первого: TPlayerone = class(TImageSprite). Private. Lngpolet:integer; Oldlngpolet:integer; Protected. Procedure DoMove(MoveCount: Integer); override; //Добавили столкновение. Procedure DoCollision(Sprite: TSprite; var Done: Boolean); override; End; TPlayertwo = class(TImageSprite). Private. Lngpolet:integer; Oldlngpolet:integer; Protected. Procedure DoMove(MoveCount: Integer); override; Procedure DoCollision(Sprite: TSprite; var Done: Boolean); override; End;

и теперь обрабатываем DoCollision у обоих плееров:

Code: Procedure TPlayerone.DoCollision(Sprite: TSprite; var Done: Boolean); Begin. If Sprite is Tplayerfa then dead; End; Procedure TPlayertwo.DoCollision(Sprite: TSprite; var Done: Boolean); Begin. If Sprite is Tplayerfa then dead; End;

Процедура DoMove у первого игрока в корне изменяется:

Code: Procedure tPlayerone.DoMove(MoveCount: Integer); Begin. Inherited DoMove(MoveCount); Ang:=angle; X:=x+cos256(Angle)*speed; Y:=y+sin256(Angle)*speed; If y >= form1.DXDraw1.SurfaceHeight-image.Height then. Y := form1.DXDraw1.SurfaceHeight-image.Height; If x >= form1.DXDraw1.SurfaceWidth -image.Width then. X := form1.DXDraw1.SurfaceWidth -image.Width; If y <= 0 then. Y := 1; If x <= 0 then. X:=1; Begin. Speed:=0; If isLeft in Form1.DXInput1.States then angle:=angle-5; If isRight in Form1.DXInput1.States then angle:=angle+5; If isup in Form1.DXInput1.States then speed:=4; If isDown in Form1.DXInput1.States then speed:=-4; If isbutton2 in Form1.DXInput1.States then. Begin. X:= x+cos256 (angle+64)*3; // это у нас стрейф. Y:= y+sin256 (angle+64)*3; // 3 - на сколько быстро стрейфиться. End; If isbutton3 in Form1.DXInput1.States then. Begin. X:= x+cos256 (angle-64)*3; //тоже стрейф, только в. Y:= y+sin256 (angle-64)*3; //другую сторону. End; If isbutton1 in Form1.DXInput1.States then. Begin. If lngpolet-oldlngpolet>=250 then. Begin. Inc(lngpolet); With TPlayerFa.Create(Engine) do. Begin. Image := form1.DXImageList1.Items.Find('pul'); X:=self.X+cos256(ang)*50; Y:=self.y+sin256(ang)*50; Anglefa:=ang; Oldlngpolet := lngpolet; End; End; End; Lngpolet := lngpolet + MoveCount; End; Collision; End;

Аналогично и у второго плеера:

Code: Procedure TPlayertwo.DoMove(MoveCount: Integer); Begin. Inherited DoMove(MoveCount); Ang2:=angle; X:=x+cos256(Angle)*speed2; Y:=y+sin256(Angle)*speed2; If y >= form1.DXDraw1.SurfaceHeight-image.Height then. Y := form1.DXDraw1.SurfaceHeight-image.Height; If x >= form1.DXDraw1.SurfaceWidth -image.Width then. X := form1.DXDraw1.SurfaceWidth -image.Width; If y <= 0 then. Y := 1; If x <= 0 then. X:=1; Begin. Speed2:=0; If isbutton6 in Form1.DXInput1.States then angle:=angle-5; If isbutton7 in Form1.DXInput1.States then angle:=angle+5; If isbutton4 in Form1.DXInput1.States then speed2:=4; If isbutton5 in Form1.DXInput1.States then speed2:=-4; If isbutton9 in Form1.DXInput1.States then. Begin. X:= x+cos256 (angle-64)*3; Y:= y+sin256 (angle-64)*3; End; If isbutton10 in Form1.DXInput1.States then. Begin. X:= x+cos256 (angle+64)*3; Y:= y+sin256 (angle+64)*3; End; If isbutton8 in Form1.DXInput1.States then. Begin. If lngpolet-oldlngpolet>=250 then. Begin. Inc(lngpolet); With TPlayerFa.Create(Engine) do. Begin. Image := form1.DXImageList1.Items.Find('pul'); X:=self.X+cos256(ang2)*50; Y:=self.y+sin256(ang2)*50; Anglefa:=ang2; Oldlngpolet := lngpolet; End; End; End; Lngpolet := lngpolet + MoveCount; End; Collision; End;

И последнее в FormCreate добавляем, чтобы второй игрок креатился:

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. With TPlayerone.Create(Dxspriteengine1.Engine) do. Begin. PixelCheck := True; Image := form1.dxImageList1.Items.Find('krut'); X:=350; Y:=250; Width := Image.Width; Height := Image.Height; End; With TPlayertwo.Create(Dxspriteengine1.Engine) do. Begin. PixelCheck := True; Image := form1.dxImageList1.Items.Find('krut'); X:=50; Y:=250; Width := Image.Width; Height := Image.Height; End;

И пару советов, для дебага можно выводить любую переменную на экран. Для этого в DXTimer добавим следующие строчки:

Code: Procedure TForm1.DXTimer1Timer(Sender: TObject; LagCount: Integer); Begin. If not DXDraw1.CanDraw then exit; DXInput1.Update; DXSpriteEngine1.Move(LagCount); DXSpriteEngine1.Dead; DXDraw1.Surface.Fill(0); DXSpriteEngine1.Draw; With DXDraw1.Surface.Canvas do. Begin. Brush.Style := bsClear; //стиль. Font.Color := clWhite; //цвет текста. Font.Size := 12; // размер. Textout(0, 0, 'FPS: '+inttostr(DXTimer1.FrameRate)); //вывод текста. Textout(0, 24, 'спрайты: '+inttostr(DXSpriteEngine1.Engine.AllCount)); Release; End; DXDraw1.Flip; End;

Здесь я вывожу Fps (кадры в секунду), и количество спрайтов на экране.

Д/З: 1. Сделай анимированные патроны. 2. Реализуй, чтобы вторым игроком управлял не человек, а созданный тобой интеллект. 3. Сделай так, чтобы вёлся счёт фрагов. 4. После смерти любого игрока, чтобы через 5 сек. происходил респаун.

Вот архив всего, что мы сегодня натворили: part3.rar(18kB).

Если у вас возникли какие-то вопросы или проблемы, пишите мне.

Автор: Влад Энгельгардт

©Drkb::03931.

Изучаем DelphiX (Часть 4).

Изучаем DelphiX (Часть 4).

Изучаем DelphiX. Часть 4: Разбираем классы.

Автор: Влад Энгельгардт

"Классы - это хорошо :)".

В этой части, дорогие мои читатели, мы разберем классы. Здесь будет рассказано, как создать грамотный, читаемый, и не тормозной код (на сколько это возможно).

Для начала реализуем наше Д/З:

1. Сделай анимированные патроны. Для начала я заменил в DXImageList спрайт "pul" другой картинкой вот такой:

а размер кадра 26X40.

В конструктор патрона нужно вставить анимацию:

Code: Constructor TPlayerFa.Create(AParent: TSprite); Begin. Inherited Create(AParent); Image := form1.DXImageList1.Items.Find('pul'); Width := Image.Width; Height := Image.Height; AnimCount := Image.PatternCount; // вот эти. AnimLooped := True; // три строчки. AnimSpeed := 10 / 1000; // с которыми вы уже знакомы. End;

Вот и всё с этим вопросом.

2. Реализуй, чтобы вторым игроком управлял не человек, а созданный тобой интеллект. Я не хочу потом повторяться, об этом ты прочитаешь в 5 части, и она будет посвящена "AI".

3. Сделай так, чтобы вёлся счёт фрагов. Добавляем перед implementation в Var две переменные: Fragpl, fragpl2 :integer;

И для отображения наших фрагов вставляем следующие строчки и он изменяется следующим образом:

Code: Procedure TForm1.DXTimer1Timer(Sender: TObject; LagCount: Integer); Begin. If not DXDraw1.CanDraw then exit; DXInput1.Update; DXSpriteEngine1.Move(LagCount); DXSpriteEngine1.Dead; DXDraw1.Surface.Fill(0); DXSpriteEngine1.Draw; With DXDraw1.Surface.Canvas do. Begin. Brush.Style := bsClear; Font.Color := clWhite; Font.Size := 12; //это первого плеера фраги. Textout(30, 35, 'Фраги первого игрока: '+inttostr(fragpl)); //это второго плеера. Textout(240, 35, 'Фраги второго игрока: '+inttostr(fragpl2)); Textout(0, 0, 'FPS: '+inttostr(DXTimer1.FrameRate)); Textout(0, 24, 'Спрайтов: '+inttostr(DXSpriteEngine1.Engine.AllCount)); Release; End; DXDraw1.Flip; End;

И ещё маленький штрих, без которого некуда:

Code: Procedure TPlayerone.DoCollision(Sprite: TSprite; var Done: Boolean); Begin. If Sprite is Tplayerfa then dead; Fragpl2:=fragpl2+1; End; Procedure TPlayertwo.DoCollision(Sprite: TSprite; var Done: Boolean); Begin. If Sprite is Tplayerfa then dead; Fragpl:=fragpl+1; End;

4. После смерти любого игрока, чтобы через 5 сек. происходил респаун. Для этого на форму добавляем обыкновенный таймер. Находится он в закладки System, и выглядит также как DXTimer. И устанавливаем свойства следующим образом: Enabled = false Interval = 5000.

А в событие OnTimer:

Code: If plres=true then. Begin. With TPlayerone.Create(Dxspriteengine1.Engine) do. Begin. PixelCheck := True; Image := form1.dxImageList1.Items.Find('krut'); X:=random(450); Y:=random(450); Width := Image.Width; Height := Image.Height; End; End; If plres=false then. Begin. With TPlayertwo.Create(Dxspriteengine1.Engine) do. Begin. PixelCheck := True; Image := form1.dxImageList1.Items.Find('krut'); X:=random(450); Y:=random(450); Width := Image.Width; Height := Image.Height; End; End; Timer1.Enabled := false; End;

Теперь перед implementation в var добавляем переменную типа boolean:

Code: Plres:boolean; // переменная респавна true= погиб 1 игрок false 2 игрок.

В событие FormCreate добавляем одну единственную команду: randomize;

И финальный штрих, процедуру DoCollision у каждого игрока изменяем следующим образом:

Code: Procedure TPlayerone.DoCollision(Sprite: TSprite; var Done: Boolean); Begin. If Sprite is Tplayerfa then. Begin. Dead; Fragpl2:=fragpl2+1; Plres:=true; Form1.Timer1.enabled:=true; End; End; Procedure TPlayertwo.DoCollision(Sprite: TSprite; var Done: Boolean); Begin. If Sprite is Tplayerfa then. Begin. Dead; Fragpl:=fragpl+1; Plres:=false; Form1.Timer1.enabled:=true; End; End;

Вот и всё, что нужно было сделать дома :).

Ну что, приступим, для начала я расскажу о разных способах создания спрайтов: 1. Это наш способ, мы использовали его в этом туториале. При создании формы, создавался объект, т.е. это выглядит так:

Code: Procedure Tformmy.FormCreate(Sender: TObject); Begin. With TPlayer.Create(Dxspriteengine1.Engine) do. Begin. PixelCheck := True; Image := dxImageList.Items.Find(skinspl1); X:=10; Y:=12; Width := Image.Width; Height := Image.Height; End; End;

Здесь, при создании спрайта, мы определяем его свойства. Значит, обрабатывать конструктор TPlayer нам ненужно.

Следующий способ, это способ конструктора. В конструкторе мы заранее задаём свойства будущего спрайта, но Create мы обрабатываем в FormCreate.Вот пример:

Code: Constructor TPlayerFa.Create(AParent: TSprite); Begin. Inherited Create(AParent); Image := formmy.DXImageList.Items.Find(pus2); Width := Image.Width; Height := Image.Height; AnimCount := Image.PatternCount; AnimLooped := True; AnimSpeed := speedanimpul / 1000; End;

Обычно этот способ используют для патронов.

И последний способ - это создания типов. Например, мы создали класс:

Code: TPlayer = class(TImageSpriteex). Private. Speed:Single; Public. Procedure DoMove(MoveCount: Integer); override; End;

Теперь перед implementation в var обозначаем наш класс как тип:

Code: Var. Form1: TForm1; Player: TPlayer; Implementation.

Теперь в свойствах DxDraw находим событие DXDrawInitialize и вставляем следующее:

Code: Player := TPlayer.Create(DXSpriteEngine1.Engine); Player.Image := DXImageList.Items.Find('Player'); Player.X := 250; Player.Y := 250; Player.Width := Player.Image.Width; Player.Height := Player.Image.Height;

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

И ещё очень важный момент, создавайте свои функции и процедуры, это очень удобно.

Теперь насчёт Collision: Во-первых, если объект с чем-то взаимодействует, то не забываете в DoMove вставлять: Collision;

Во-вторых, там где нужен точный Collision используйте "PixelСheck:=true"; там где точность при столкновении не нужна "PixelCheck := False;" , или вообще ничего не писать.

Angle: это процедура очень удобная, но есть одно большое НО, она не подходит для разворота очень больших объектов. Происходит очень большое количество вычислений, и игра начинает зверски тормозить или точнее уменьшается число Fps.

Анимация в DelphiX капризная вещь, иногда не дружит с PixelCheck, иногда с Collision, но это бывает очень редко. В анимации, как и в статичном спрайте, главное правильно указывать Transparent Color, хотя DelphiX пытается определить его сам (и у него иногда это хорошо получается), следует смотреть какой цвет он выбрал.

Размер кадра вычитывается ручками (если ты рисовал сам), если ты создавал анимацию в каком-то редакторе, то ты должен знать размер кадра т.к. ты его сам указывал.

С DXInput бывает всего одна проблема это смешивание кнопок, т.е. на одной кнопке находиться несколько действий.

Ну, вот думаю и всё что я могу тебе посоветовать по этому поводу. Спросишь ты, а причём тут "Разбираем классы", некоторое написанное выше заставляет наши спрайты меньше тормозить, а разбираем мы их потому, что решаем что хорошо, а что плохо.

Есть вопросы, пиши мне.

Скачать файл с ответами на Д/З можно здесь: part4.rar.

Автор: Влад Энгельгардт

©Drkb::03932.

Изучаем DelphiX (Часть 5).

Изучаем DelphiX (Часть 5).

Изучаем DelphiX. Часть 5: AI.

Автор: Влад Энгельгардт

"Все люди - всего на всего сложный AI".

Здравствуйте! Сегодня я реализую у вас на глазах, простенький Ai который будет стрелять по вам, и двигаться к вам. Бороться с ним будет "очень просто" (клавиатуру не поломайте), не смотря на его простенькое строение. В виде шаблона я возьму пример из части 4.

Начнём делать всё постепенно, нам ведь некуда тропится, правильно?

Для начала в Uses добавим модуль math. В этом модуле находятся процедуры с математикой.

Далее добавляем перед implementation в var:

Code: Plres:boolean; // plres - респаун: true - погиб 1 игрок, false - 2 игрок. Fa:boolean; //Выстрел нашего Ai true - стрелял, false - нет. Player:TPlayerone; Playerai:TPlayertwo;

Процедура Domove изменяется у нашего Ai:

Code: Procedure TPlayertwo.DoMove(MoveCount: Integer); Begin. Inherited DoMove(MoveCount); Ang2:=angle; If y >= form1.DXDraw1.SurfaceHeight-image.Height then. Y := form1.DXDraw1.SurfaceHeight-image.Height; If x >= form1.DXDraw1.SurfaceWidth -image.Width then. X := form1.DXDraw1.SurfaceWidth -image.Width; If y <= 0 then. Y := 1; If x <= 0 then. X:=1; Begin. If fa=true then. Begin. If lngpolet-oldlngpolet>=250 then. Begin. Inc(lngpolet); With TPlayerFa.Create(Engine) do. Begin. Image := form1.DXImageList1.Items.Find('pul'); X:=self.X+cos256(ang2)*55; Y:=self.y+sin256(ang2)*55; Anglefa:=ang2; Oldlngpolet := lngpolet; End; Fa:=false; End; End; Lngpolet := lngpolet + MoveCount; End; Collision; End;

Теперь идём в FormCreate и удаляем там всё кроме

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. Randomize; End;

Кликаем на DxDraw и в свойствах ищем: "OnInitialize" создаём событие, и вставляем:

Code: Playerai:= TPlayertwo.Create(DXSpriteEngine1.Engine); Playerai.Image := DXImageList1.Items.Find('krut'); Playerai.X := 50; Playerai.Y := 250; Playerai.Width := Playerai.Image.Width; Playerai.Height := Playerai.Image.Height; Player:= TPlayerone.Create(DXSpriteEngine1.Engine); Player.Image := form1.dxImageList1.Items.Find('krut'); Player.x:=350; Player.y:=250; Player.Width := Player.Image.Width; Player.Height := Player.Image.Height;

Теперь кидаем на форму простой таймер (я назвал его Ai). Параметры такие:

Code: Enabled = true. Interval = 1. Name = Ai.

Создаём событие OnTime и пишем следующее:

Code: Playerai.angle:=trunc(1/sin256(trunc((player.y-playerai.y)/(player.x-playerai.x)))); If (player.y-playerai.y < 0)and(player.x-playerai.x > 0) then. Playerai.angle:=playerai.angle+192; If (player.y-playerai.y < 0)and(player.x-playerai.x < 0) then. Playerai.angle:=playerai.angle+128; If (player.y-playerai.y > 0)and(player.x-playerai.x < 0) then. Playerai.angle:=playerai.angle+64; If player.x <= playerai.x then. Playerai.x:=playerai.x-2.5; If player.x > playerai.x then. Playerai.x:=playerai.x+2.5; If player.y <= playerai.y then. Playerai.y:=playerai.y-2.5; If player.y > playerai.y then. Playerai.y:=playerai.y+2.5; If playerai.x >= player.x-140 then. Begin. Playerai.x:=playerai.x-2.5; End; If playerai.y>= player.y-140 then. Begin. Playerai.y:=playerai.y-2.5; End; If playerai.y >=player.y-150 then. Begin. If playerai.x >=player.x-150 then. Begin. Fa:=true; End; End;

Вот и всё, мы реализовали примитивный, и простенький Ai, ни капли не реалистичный, зато очень точный. Есть маленький совет: атакуйте издалека.

Ну а теперь Д/З: 1. Осуществите более реалистичный разворот к игроку 2. Реализуйте ошибки Ai (т.е. неточное попадание и т.д.) 3. Чтобы AI не стрелял постоянно в одну и туже точку после гибели игрока 4. И вообще, придумайте что-то своё

На это Д/З я не буду писать решение в следующей части. Реализуйте это, и отправьте мне на e-mail, и если всё будет хорошо, ты получишь предложение, от которого нельзя отказаться. Жду!!

Всё, что мы на кодили, здесь: part5.rar.

Автор: Влад Энгельгардт

©Drkb::03933.

Изучаем DelphiX (Часть 6).

Изучаем DelphiX (Часть 6).

Изучаем DelphiX. Часть 6: Мультиплеер.

Автор: Влад Энгельгардт

"SINGLE-хорошо, а MULTIPLAYER - лучше".

Здравствуйте дорогие мои читатели. Сегодня мы будем говорить о мультиплеере. Точнее об его создании в DelphiX. В DelphiX это реализуется с помощью компонента:

DXPlay. Многие, кто пытался что-то сделать на DXPlay, сталкивался с такой проблемой: что если вызывать диалог с DXPlay то получаем непонятный текст:

Устранить ее очень легко. Дело в том, что из-за "НЕРУССКОГО" происхождения программист Hiroyuki Hori в DXPlayFm.dfm в некоторых местах поставил шрифт: "Terminal", а нам нужен "MS Sans Serif". Поэтому то и всё так исковеркано. Я исправил эту проблему вот так:

И выкладываю исправленный мною модуль DXPlayFm.dfm, и более того, он русифицирован. Так что пользуйтесь на здоровье :) DXPlayFm.rar.

Сегодня мы напишем простенькую, мультиплеерную гаму. В этом я помогу вам. В качестве шаблона я буду использовать part2.rar. Мы его модернизируем, и предадим ему мультиплеерность. Сразу говорю, что part2.rar состоял из 2 интерактивных объектов, соответственно и в наш мультиплеер можно играть только вдвоем.

Теперь я расскажу, как нужно модернизировать пример из второй части под шестой :).

На мой взгляд, эта часть является единственно растолковывающая создание мультиплеера под DelphiX. Сколько я прочитал статей по программированию мультиплеера на DelphiX, ничего путного не увидел. Здесь я использую простой алгоритм. Принцип его следующий: передаются не координаты объекта, а клавиши, которые были нажаты на удалённой машине.

Кидаем на форму компонент DXPlay и устанавливаем вот такие свойства:

Code: MaxPlayers = 2, GUID = {218A0D84-949C-42BC-A97B-40C3E3A642F1}.

GUID можно создать любой достаточно нажать на кнопку New.

Добавляем в uses модуль: DirectX.

После uses создаём список констант:

Code: Const. DXACTION_MESSAGE = 1; // Это нажата клавиша действия. DXKEY_LEFT = 1; // двигаемся влево. DXKEY_RIGHT = 2; // двигаемся вправо. DXKEY_SHOOT = 3; // Стреляем.

Создаём новый тип для наших ACTION сообщений:

Code: Type. TDXActionMessage = record. DwType: DWORD; ActionCode: Integer; End;

Далее идут классы спрайтов: Единственное, что поменялось это класс TBOSS, я его переименовал в TPLU. Когда мы поменяли названия то и картинку нужно изменить на более подходящую.

Заходим в DXImageList и переименовываем спрайт Boss на Plu . А вот картинка:

В Var перед implementation обозначаем два наших класса:

Code: Var. Form1: TForm1; Plu:Tplu; PlayerSprite:TPlayerSprite; Implementation.

Теперь подходим к процедуре TPlayerSprite.DoMove. Она должна выглядеть вот так:

Code: Procedure TPlayerSprite.DoMove(MoveCount: Integer); Var. Msg: ^TDXActionMessage; //Само сообщение. MsgSize: Integer; //размер сообщения. Begin. Inherited DoMove(MoveCount); If form1.DXPlay1.Players.Count =2 then // пока в игру не зайдёт второй игрок. // ни кто, не двинется. Begin. If isLeft in Form1.DXInput1.States then. Begin. X:=x-5; MsgSize := SizeOf( TDXActionMessage ); GetMem(Msg, MsgSize); Msg.dwType := DXACTION_MESSAGE; //тип сообщения. Msg.ActionCode := DXKEY_LEFT; //действие. Form1.DXPlay1.SendMessage(DPID_ALLPLAYERS,msg,msgsize); //отсылаем всем. End; If isRight in Form1.DXInput1.States then. Begin. X:=x+5; MsgSize := SizeOf( TDXActionMessage ); GetMem(Msg, MsgSize); Msg.dwType := DXACTION_MESSAGE; Msg.ActionCode := DXKEY_RIGHT; Form1.DXPlay1.SendMessage(DPID_ALLPLAYERS,msg,msgsize); End; If isup in Form1.DXInput1.States then. Begin. If lngpolet-oldlngpolet>=900 then. Begin. Inc(lngpolet); With TPlayerFa.Create(Engine) do. Begin. MsgSize := SizeOf( TDXActionMessage ); GetMem(Msg, MsgSize); Msg.dwType := DXACTION_MESSAGE; Msg.ActionCode := DXKEY_SHOOT; Form1.DXPlay1.SendMessage(DPID_ALLPLAYERS,msg,msgsize); PixelCheck := True; Image := form1.dxImageList1.Items.Find('Pula'); X := Self.X+Self.Width -40; Y := Self.Y+Self.Height -80 ; Width := Image.Width; Height := Image.Height; Stril:=-4; End; Oldlngpolet := lngpolet; End; End; If y >= form1.DXDraw1.SurfaceHeight-image.Height then. Y := form1.DXDraw1.SurfaceHeight-image.Height; If x >= form1.DXDraw1.SurfaceWidth -image.Width then. X := form1.DXDraw1.SurfaceWidth -image.Width; If y <= 0 then. Y := 1; If x <= 0 then. X:=1; Lngpolet := lngpolet + MoveCount; Collision; End; End;

Теперь, как вы понимаете, так как TBoss уже не существует, то и некоторые процедуры должны быть пусты:

Code: Procedure TPLU.DoMove(MoveCount: Integer); Begin. Inherited DoMove(MoveCount); Collision; End; Constructor TPLU.Create(AParent: TSprite); Begin. Inherited Create(AParent); End;

Далее очищаем событие для формы OnCreate и пишем в нём:

Code: Procedure TForm1.FormCreate(Sender: TObject); Begin. Try. DXPlay1.Open; Except. On E: Exception do. Begin. Application.ShowMainForm := False; Application.HandleException(E); Application.Terminate; End; End; With TBackgroundSprite.Create(DXSpriteEngine1.Engine) do. Begin. SetMapSize(1,1); Image := dxImageList1.Items.Find('bg'); Z:= -2; Tile := True; End; End;

Далее кликаем по компоненту DXPlay создаём событие: OnMessage.

И пишем следующее:

Code: Procedure TForm1.DXPlay1Message(Sender: TObject; From: TDXPlayPlayer; Data: Pointer; DataSize: Integer); Begin. If TDXActionMessage( Data^ ).actioncode AND DXKEY_LEFT = DXKEY_LEFT then. Plu.X:=plu.X -5; // получаем сообщение влево, двигаем удалённого. //р1ауега в лево. If TDXActionMessage( Data^ ).actioncode AND DXKEY_RIGHT = DXKEY_RIGHT then. Plu.X:=plu.X +5; // получаем сообщение вправо, двигаем удалённого. //р1ауега в право. If TDXActionMessage( Data^ ).actioncode AND DXKEY_SHOOT = DXKEY_SHOOT then. Begin // получаем сообщение - удалённый игрок выстрелил, // создаём патрон на месте PLU. With TPlayerFa.Create(dxspriteengine1.Engine) do. Begin. PixelCheck := True; Image := form1.dxImageList1.Items.Find('Pula'); X := plu.X+plu.Width-70; Y := plu.Y+plu.Height+10; Width := Image.Width; Height := Image.Height; Stril:=4; Collision; End; End; End;

Далее кликаем по DXDraw создаём событие Initialize и в нем пишем:

Code: Plu:= Tplu.Create(DXSpriteEngine1.Engine); Plu.PixelCheck := True; Plu.Image := form1.dxImageList1.Items.Find('plu'); Plu.x:=350; Plu.y:=10; Plu.Width := plu.Image.Width; Plu.Height := plu.Image.Height; PlayerSprite:= TPlayerSprite.Create(DXSpriteEngine1.Engine); PlayerSprite.PixelCheck := True; PlayerSprite.Image := form1.dxImageList1.Items.Find('Pla'); PlayerSprite.x:=350; PlayerSprite.y:=500; PlayerSprite.Width := PlayerSprite.Image.Width; PlayerSprite.Height := PlayerSprite.Image.Height;

Вот, и всё запускаем, и радуемся. А теперь я расскажу, как это всё работает.

Прежде чем начать писать мультиплеер, нужно осознавать, что тебе придётся думать за каждую из удалённых машин. Как она получит пакет, кому что нужно будет отправить и так далее. Так вот, в событии Message в DXPlay1 обрабатываются всё принятые сообщения, а отсылать их можно любым плеером из любого места в коде. Так вот когда один из игроков запускает игру, а другой присоединяется к нему, происходит такая картина:

В нашем примере все действия, которые происходят на другой машине, отражается на спрайте Plu.

Скачать всё, что мы творили можно вот здесь: part6.rar.

P.S Назвал я класс PLU потому что, так проще, расшифровывается как плеер удаленный.

P.S.S Я устал уже отвечать на такие письма типа: "У меня не распаковывается архив?" так вот, говорю, всё архивы запакованы WinRAR 3.0.

Автор: Влад Энгельгардт

©Drkb::03934.

Изучаем DelphiX (Часть 7).

Изучаем DelphiX (Часть 7).

Изучаем DelphiX. Часть 7: Звуки и музыка.

Автор: Влад Энгельгардт

"Звуки и музыка создают атмосферу в игре".

Здравствуйте дорогие мои читатели, сегодня мы займёмся воспроизведением звуков и музыки в игре. Займёмся в начале звуками. В этом уроке рассмотрим два способа воспроизведения звука. За основу я решил взять седьмую часть. Теперь рассмотрим компоненты, с помощью которых мы будем осуществлять воспроизведение музыки.

DXSound - в общем через него звук и будет воспроизводится.

DXWave - необходим для хранения, и воспроизведения одного звука.

DXWaveList -В нём можно хранить, и воспроизводить звуки через DXSound.

Внимание, напомню, что звуки можно загружать в игру только в формате Wav или Dxw.

Ну, так что, приступим. Для начала кидаем компонент DxSound на форму. Затем кидаем DXWaveList и в закладке Properties напротив DXSound выбираем наш саунд :). Теперь давайте загрузим наш первый звук. Это будет естественно выстрел. Он будет у нас вот таким: fa.wav. Теперь щёлкаем по нашему компоненту DxWaveList, и находим Items с удовольствием нажимаем, и далее всё также, как мы работали с ImageList. Добавим звук и назовем его Fa. Теперь по идеи стреляют у нас оба класса и игрок и плеер, так что добавляем это в процедуры DoMove. При событии создания патрона. Так должно выглядеть для каждого класса.

Для Playerone:

Code: If isbutton1 in Form1.DXInput1.States then. Begin. If lngpolet-oldlngpolet>=250 then. Begin. Inc(lngpolet); With TPlayerFa.Create(Engine) do. Begin. Form1.DXWaveList1.Items.Find('fa').Play(true); Image := form1.DXImageList1.Items.Find('pul'); X:=self.X+cos256(ang)*55; Y:=self.y+sin256(ang)*55; Anglefa:=ang; Oldlngpolet := lngpolet; End; End; End;

Для Playertwo:

Code: If fa=true then. Begin. If lngpolet-oldlngpolet>=250 then. Begin. Inc(lngpolet); With TPlayerFa.Create(Engine) do. Begin. Form1.DXWaveList1.Items.Find('fa').Play(true); Image := form1.DXImageList1.Items.Find('pul'); X:=self.X+cos256(ang2)*55; Y:=self.y+sin256(ang2)*55; Anglefa:=ang2; Oldlngpolet := lngpolet; End; Fa:=false; End; End;

Следующий пример со стереоэффектом. Этот пример будет способен различать в какой стороне находится патрон и "снижать громкость" в противоположном динамике.

Let's GO!! :).

Перед implementation в Var добавляем две переменные: pulxpl,CurrentPanpl:integer;

Первая - это X патрона, вторая это высота звука и место расположения.

Теперь в процедуру TPlayerFa.DoMove добавляем некоторые строчки, и она становится вот такой:

Code: Procedure TPlayerFa.DoMove(MoveCount: Integer); Begin. Inherited DoMove(MoveCount); Angle := anglefa; X:=x+cos256(angle)*8; Y:=y+sin256(angle)*8; Pulxpl := trunc(x); //передаём переменной значение Х патрона. CurrentPanpl := -20000 * pulxpl div form1.DXDraw1.ClientWidth + 10000; // И так всё //понятно. Form1.dxwavelist1.Items.Find('fa').pan := CurrentPanpl; //Присваиваем значение звуку. If X>= 800 then Dead; If y>= 600 then Dead; If X<= 0 then Dead; If y<= 0 then Dead; Collision; End;

Конечно, это самый примитивный способ, и требует доработки, но всё же годен для использования, например, в аркадах. Что касается музыки, то для мелких проектов использовать Midi или Mod, а в более серьёзных, где качество звука должно быть на высоте, надо использовать более качественные форматы, или библиотеки. А так, для воспроизведения музыки в игре можно пользоваться и MediaPlayer (стандартным компонентом для воспроизведения музыки). Я добавил музыку в последний пример с помощью MediaPlayer. Совет для всех: чтобы музыка корректно воспроизводилась у всех, переписываете её в папку с игрой, и в MediaPlayer указывайте не полный путь, а только название файла. И ещё совет, MediaPlayer1.Play; вставляёте в самом конце DXDraw Initialize иначе может случиться, что игра ещё не загрузилась, а музыка будет играть.

Вот и всё. Скачать можно первый пример, второй пример.

И ещё, пишите о том, что хотите прочитать, это мне очень важно по вашим письмам я строю план следующей части. Нет писем нет частей :(.

Автор: Влад Энгельгардт

©Drkb::03935.

Из ресурсов поочередно загружать глифы для кнопок SpeedButton.

Автор: Dennis Passmore.

Из Paradox в Access при помощи ADO.

В данной статье мы обратим внимание на компонент TADOCommand и использование языка SQL DDL (Data Definition Language), с целью помочь Вам с проблемой переноса данных BDE/Paradox в ADO/Access.

Edit с возможностью автоматического выбора

...маленький компонент THintEdit, порожденный от TCustomEdit, который представляет собой с виду обычный TEdit элемент с возможностью автоматического выбора стринговых значений из скрытого списка (так, как это реализовано в Netscape Navigator'е). Описание особенно не нужно, так как выполнено все достаточно элементарно: значения для выбора заносятся в свойство HintList, тип свойства TStrings. При нажатии клавиш вверх/вниз выбираются значения, соответствующие набранным начальным символам.

Класс-оболочка для объекта синхронизации WaitableTimer.

Линза

Реализация 1 - на Паскале.

Если линза на экpане - окpужность (x0,y0,r0), то в точках (x,y), для котоpых (x-x0)2+(y-y0)2<=r02,pисуется точка, котоpая, если бы линзы не было, изобpажалась бы в точке (x0+(x-x0)*k1,y0+(y-y0)*k), где k=const1 / ([sqrt]((x-x0)2+(y-y0)2) + const2). Можно заpанее пpосчитать таблицу смещений - array[-r0..r0,-r0..r0] of integer.

Code: {$A+,B-,D+,E+,F-,G+,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+,Y+}. {$M 16384,0,655360}. Uses CRT; Const vx0 = 3; Vy0 = 2; V0 = vx0; R0 = 50; R02 = (r0-v0)*(r0-v0); D = r02 * 10 div 10; Type ScreenType = Array[0..199,0..319] of Byte; DispType = Array[-r0..r0,-r0..r0] of Integer; Var. Screen : ScreenType Absolute $a000:$0000; Buffer1, Buffer2 : ^ScreenType; Disp : ^DispType; X,y,vx,vy,r2,c : LongInt; Procedure Move(Var A,B; Count: Word); Assembler; Asm. Push ds. Mov cx, Count. Les di, B. Lds si, A. Shr cx, 1. Jz @zero. Rep movsw. @zero: pop ds. End; BEGIN. Asm. Mov ax, $13. Int $10. End; New(Buffer1); New(Buffer2); New(Disp); FillChar(Screen, SizeOf(Screen), 3); Y:=0; Repeat. For x:=0 to 319 do Screen[y,x]:=11; Inc(y,10); Until y>199; X:=0; Repeat. For y:=0 to 199 do Screen[y,x]:=11; Inc(x,10); Until x>319; Move(Screen, Buffer1^, SizeOf(Screen)); Move(Buffer1^,Screen,64000); For y:=-r0 to r0 do. For x:=-r0 to r0 do. Begin. R2:=x*x+y*y; If r2>r02 then Disp^[y,x] := y*320+x. Else. Disp^[y,x]:=(y*(r2+d)div(r02+d))*320+(x*(r2+d)div(r02+d)); End; X:=r0; Y:=r0; Vx:=vx0; Vy:=vy0; Repeat. Asm. Mov ax, Integer(y). Mov bx, 320. Imul bx. Add ax, Integer(x). Mov di, ax. Mov dx, -r0*320-r0. Les si, Disp. Mov ch, 2*r0+1. @next_dy: mov cl, 2*r0+1. @next_dx: Mov es, Word(Disp+2). Mov bx, es:[si]. Mov es, Word(Buffer1+2). Mov al, es:[di+bx]. Mov bx, Seg(Screen). Mov es, bx. Mov bx, dx. Mov es:[di+bx], al. Add si, 2. Inc dx. Dec cl. Jnz @next_dx. Add dx, 320-(2*r0+1). Dec ch. Jnz @next_dy. End; If ((x+vx)>=r0)and ((x+vx)<=319-r0)then Inc(x, vx). Else vx:=-vx; If ((y+vy)>=r0)and ((y+vy)<=199-r0)then Inc(y,vy). Else vy:=-vy; Delay(25); Until Port[$60]=$01; Dispose(Buffer1); Dispose(Buffer2); Dispose(Disp); Asm. Mov ax, $03. Int $10. End; END.

Лимит на время выполнения программы

Code: { In der Projekt Datei (.dpr): In your project's file (.dpr): } Uses. Forms, Sysutils, Dialogs, MyProgr in my_prog1.pas {Form1}; Const. Email = 'my.mail@provider.xyz'; Homepage = 'http://www.myhomepage.com'; // Limit the execution time to 04/21/2003. // Gultigkeit auf 21. April 2003 begrenzen. YearExp = 2003; MonthExp = 4; DayExp = 21; Function CheckDate(y, m, d: Integer): Boolean; Begin. Result := True; If (Date > EncodeDate(y, m, d)) then. Begin. ShowMessage('End of usage exceeded. Download a new'+ 'version at' + ^j + homepage+ ^j + ' or contact: ' + email); Result := False; // halt; End; End; {$R *.RES}. Begin. If CheckDate(YearExp, MonthExp, DayExp) then. Begin. Application.Initialize; Application.Title := 'Some Title'; Application.CreateForm(TForm1, Form1); Application.Run; End; End.

Клонирование объектов.

Клонирование объектов

Клонирование объектов.

Создать копию объекта в Delphi очень просто. Конвертируем объект в текст, а затем - обратно. При этом будут продублированы все свойства, кроме ссылок на обработчики событий. Для преобразования компонента в файл и обратно нам понадобятся функции потоков WriteComponent(TComponent) и ReadComponent(TComponent). При этом в поток записывается двоичный ресурс. Последний с помощью функции ObjectBinaryToText можно преобразовать в текст. Создадим на их основе функции преобразования:

Code: Function ComponentToString(Component: TComponent): string; Var. Ms: TMemoryStream; Ss: TStringStream; Begin. Ss := TStringStream.Create(' '); Ms := TMemoryStream.Create; Try. Ms.WriteComponent(Component); Ms.position := 0; ObjectBinaryToText(ms, ss); Ss.position := 0; Result := ss.DataString; Finally. Ms.Free; Ss.free; End; End; Procedure StringToComponent(Component: TComponent; Value: string); Var. StrStream:TStringStream; Ms: TMemoryStream; Begin. StrStream := TStringStream.Create(Value); Try. Ms := TMemoryStream.Create; Try. ObjectTextToBinary(StrStream, ms); Ms.position := 0; Ms.ReadComponent(Component); Finally. Ms.Free; End; Finally. StrStream.Free; End; End;

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

Code: Object Form1: TForm1. Left = 262. Top = 129. Width = 525. Height = 153. Caption = 'Form1' Color = clBtnFace. Font.Charset = DEFAULT_CHARSET. Font.Color = clWindowText. Font.Height = -11. Font.Name = 'MS Sans Serif' Font.Style = []. OldCreateOrder = False. Scaled = False. PixelsPerInch = 96. TextHeight = 13. Object Button1: TButton. Left = 16. Top = 32. Width = 57. Height = 49. Caption = 'Caption' TabOrder = 0. OnClick = Button1Click. End. End. Procedure TForm1.Button1Click(Sender: TObject); Var. Button: TButton; OldName: string; Begin. Button := TButton.Create(self); //...сохраняем имя компонента. OldName := (Sender as TButton).Name; //...стираем имя компонента, чтобы избежать конфликта имен. //...После этого Button1 станет = nil. (Sender as TButton).Name := ''; //...преобразуем в текст и обратно. StringToComponent( Button, ComponentToString(Sender as TButton) ); //...дадим компоненту уникальное(?) имя. Button.Name := 'Button' + IntToStr(random(1000)); //...вернем исходному компоненту имя. //...После этого Button1 станет снова указывать на объект. (Sender as TButton).Name := OldName; //...размещаем новую кнопку справа от исходной. Button.parent := self; Button1.Tag := Button1.Tag + 1; Button.Left := Button.Left + Button.Width * Button1.Tag + 1; End;

Приведенный метод не дублирует указатели на обработчики событий. Однако, если таким образом дублировать формы, то все дочерние компоненты и все обработчики сохранятся.

составление статьи: Андрей Чудин, ЦПР ТД Библио-Глобус

Взято из http://delphi.chertenok.ru.

©Drkb::00126.

Криптоалгоритм DES.

Особенностью этой криптосистемы является использование операций циклического сдвига, зависящих от преобразуемых данных RC5 [12,13]. Это задает непредопределенность операций преобразования, выполняемых над преобразуемыми подблоками данных, что по замыслу разработчиков должно привести к до-стижению высокой криптостойкости. В этой криптосистеме пре-дусмотрена возможность задания пользователем числа раундов и размера входного блока данных. Входной блок разбивается на два подблока одинаковой длины. Обозначим длину подблока в битах через Ъ. Шифрование заключается в поочередном преоб-разовании подблоков с использованием операций поразрядно-го суммирования по модулю два, суммирования по модулю 26 и управляемых операций циклического сдвига. Варианты опера-ции циклического сдвига различаются величиной сдвига от 0 до Ь - 1 бит. Для обозначения операции циклического сдвига подблока (слова) W на х бит будем применять запись W <<< х (сдвиг влево) и W >>> х (сдвиг вправо). Для выбора конкретной модификации операции циклического сдвига используется log2 b младших разрядов управляющего блока.

На каждом раунде преобразования используется отдельная пара подключей, поэтому при выборе различного числа раун-дов преобразования используется ключ шифрования различной длины. Для удобства пользователей в шифре RC5 используется алгоритм инициализации, выполняемый однократно при запуске криптосистемы. На этом этапе предвычислений по секретному ключу пользователя в зависимости от заданного числа раундов R формируется ключ шифрования в виде последовательности, содержащей 2(R+1) b-битовых подключей. Подключи используются по фиксированному расписанию, т. е. для всех входных блоков на данном шаге преобразования используется один и тот же подключ. Для того, чтобы указать значения конкретных па-раметров настройки алгоритма применяется запись RC5-b/R/l, где l -длина секретного ключа в байтах.

Типичной является модификация RC5-32/12/16, ко-торая соответствует 64-битовому входному блоку данных, 128-битовому секретному ключу и 12 раундам шифрования. Эта модификация является стойкой к известным методам криптоанализа и может применяться для защиты данных в авто-матизированных системах обработки информации и управления. В случае применения 64-разрядных микропроцессоров целе-сообразно применение модификации RC5-64/12/16, которая обеспечит более высокую скорость преобразования. Кроме того, при преобразовании 128-битовых блоков исходного текста повышается стойкость шифрования за счет увеличения числа управляющих битов с 5 до 6.

Алгоритм предвычислений формирует ключ шифрования необходимого размера, при этом используются процедуры, которые обеспечивают влияние каждого бита секретного ключа на каждый бит ключа шифрования. По значению клю-ча шифрования трудно восстановить секретный ключ. Мы не будем останавливаться на описании алгоритма предвы-числений, поскольку могут быть применены различные его варианты. Рассмотрим процедуры шифрования и дешифро-вания, которые составляют сущность криптосистемы RC5. Обозначим ключ шифрования как последовательность подключей Q0, Q1, ..., Q2R+1. Процедуры шифрования и дешифрования блока Т = A | В описываются следующими простыми алгоритмами:

Когда приходит несколько пакетов в одном.

когда приходит несколько пакетов в одном

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Разбиение полученных данных через ClientSocket и ServerSocket, когда приходит несколько пакетов в одном. При получении нескольких данных по socket иногда приходят два и более пакета в одном. Здесь пример, как разбить при получении полученную строку на несколько отправленных. Зависимости: System, ScktComp. Автор: cyborg, cyborg1979@newmail.ru, ICQ:114205759, Бузулук. Copyright: Собственное написание (Осипов Евгений Анатольевич). Дата: 23 мая 2002 г. ********************************************** } {Разделитель строк, добавляется в конец отсылаемых данных, Можно написать любой, какой нравится/какой вам подойдёт}. Const Delitel : String = #13#10; {Процедура обработки строк, S-передаваемая строка, Socket - Передаваемый сокет откуда пришли данные}. Procedure Process_Message(Var S : AnsiString; Var Socket: TCustomWinSocket); Begin. {Обрабатываем здесь полученные данные S из сокета Socket}. End; {Обработака события по получению данных из ClientSocket, А так же действенно и для ServerSocket}. Procedure TMyForm.ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket); Var S1,S2 : AnsiString; I : Integer; Begin. S1:=Socket.ReceiveText; {Присваиваем S1 полученную строку из Socket}. I:=0; Repeat {Разделяем строку, если одновременно пришло несколько}. I:=Pos(Delitel,S1); {Ищем раздлелитель Delitel в строке S1}. If I<>0 then {Если найден делитель, тогда ... Если не найден, то вы не добавили в конце отсылаемой строки Delitel !}. Begin. S2:=Copy(S1,1,I-1);{Копируем одну пришедшую строку в S2}. Delete(S1,1,I+Length(Delitel)-1);{Удаляем уже скопированную строку}. Process_Message(S2,Socket); {Вызываем процедуру обработки полученных строк, Где S2 наша выделенная строка}. End; Until I=0; {Повторять, пока будет не найден разделитель Delitel}. End;

©Drkb::03565.

Кораблик

Code: Unit ship_; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; Type. TForm1 = class(TForm). Timer1: TTimer; Procedure Timer1Timer(Sender: TObject); Procedure FormActivate(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; X, y: integer; // координаты корабля (базовой точки). Implementation. {$R *.DFM}. Procedure Titanik(x, y: integer; // координаты базовой точки. Color: TColor); // цвет корабля. Const. Dx = 5; Dy = 5; Var. Buf: TColor; Begin. With form1.canvas do. Begin. Buf := pen.Color; // сохраним текущий цвет. Pen.Color := color; // установим нужный цвет. // рисуем ... // корпус. MoveTo(x, y); LineTo(x, y - 2 * dy); LineTo(x + 10 * dx, y - 2 * dy); LineTo(x + 11 * dx, y - 3 * dy); LineTo(x + 17 * dx, y - 3 * dy); LineTo(x + 14 * dx, y); LineTo(x, y); // надстройка. MoveTo(x + 3 * dx, y - 2 * dy); LineTo(x + 4 * dx, y - 3 * dy); LineTo(x + 4 * dx, y - 4 * dy); LineTo(x + 13 * dx, y - 4 * dy); LineTo(x + 13 * dx, y - 3 * dy); MoveTo(x + 5 * dx, y - 3 * dy); LineTo(x + 9 * dx, y - 3 * dy); // капитанский мостик. Rectangle(x + 8 * dx, y - 4 * dy, x + 11 * dx, y - 5 * dy); // труба. Rectangle(x + 7 * dx, y - 4 * dy, x + 8 * dx, y - 7 * dy); // иллюминаторы. Ellipse(x + 11 * dx, y - 2 * dy, x + 12 * dx, y - 1 * dy); Ellipse(x + 13 * dx, y - 2 * dy, x + 14 * dx, y - 1 * dy); // мачта. MoveTo(x + 10 * dx, y - 5 * dy); LineTo(x + 10 * dx, y - 10 * dy); // оснастка. MoveTo(x + 17 * dx, y - 3 * dy); LineTo(x + 10 * dx, y - 10 * dy); LineTo(x, y - 2 * dy); Pen.Color := buf; // восстановим старый цвет карандаша. End; End; // обработка сигнала таймера. Procedure TForm1.Timer1Timer(Sender: TObject); Begin. Titanik(x, y, form1.color); // стереть рисунок. If x < Form1.ClientWidth then. X := x + 5. Else. Begin // новый рейс. X := 0; Y := Random(50) + 100; End; Titanik(x, y, clWhite); // нарисовать в новой точке. End; Procedure TForm1.FormActivate(Sender: TObject); Begin. X := 0; Y := 100; Form1.Color := clNavy; Timer1.Interval := 50; // сигнал таймера каждые 50 мСек. End; End.

Инверсия цветов.

Инверсия цветов

Code: Function InvertBitmap(Bmp: TBitmap): TBitmap; Var. X, y: integer; ByteArray: PByteArray; Begin. Bmp.PixelFormat := pf24Bit; For y := 0 to Bmp.Height - 1 do. Begin. ByteArray := Bmp.ScanLine[y]; For x := 0 to Bmp.Width * 3 - 1 do. Begin. ByteArray[x] := 255 - ByteArray[x]; End; End; Result := Bmp; End;

ПРИМЕР ИСПОЛЬЗОВАНИЯ:

Code: Procedure TForm1.Button1Click(Sender: TObject); Begin. Image1.Picture.Bitmap := InvertBitmap(Image1.Picture.Bitmap); End;

Взято из http://forum.sources.ru.

©Drkb::03712.

Автор: Song.

Инжектирование кода.

Инжектирование кода.

Инжектирование кода.

Простой пример внедрения и выгрузки библиотеки в удаленное адресное пространство.

Скачать демонстрационный пример

Александр (Rouse_) Багель.

Http://rouse.drkb.ru.

©Drkb::02138.

Кодирование по спирали

Автор: ___Nikolay.

Code: Unit uMain; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, StdCtrls, Buttons, ExtCtrls; Type. TfmMain = class(TForm). SgMatrix: TStringGrid; EdEncode: TEdit; EdDecode: TEdit; BtEncode: TSpeedButton; BtDecode: TSpeedButton; Label1: TLabel; ChAnimation: TCheckBox; Procedure btEncodeClick(Sender: TObject); Procedure btDecodeClick(Sender: TObject); Private. { Private declarations }. Procedure ClearMatrix; // Очистит матрицу. Procedure WriteToMatrix(s: string; bSpiralWriteMode: boolean); // Записываем в матрицу. Function ReadFromMatrix(bSpiralWriteMode: boolean): string; // Считываем из матрицы. Public. { Public declarations }. End; Var. FmMain: TfmMain; Implementation. {$R *.DFM}. // Записываем в матрицу. Procedure TfmMain.WriteToMatrix(s: string; bSpiralWriteMode: boolean); Var. C, r, i, iWriteSymbols, iStep, iDirection, iIncStep, iHalfCell, x, y: integer; PCursor: TPoint; Begin. SgMatrix.Selection := TGridRect(Rect(-1, -1, -1, -1)); GetCursorPos(pCursor); IHalfCell := sgMatrix.DefaultColWidth div 2; // Половина ширины ячейки. // Символы в матрицу вносим по спирали, начиная с центра. If bSpiralWriteMode then. Begin. C := 5; // Индекс колонки. R := 5; // Индекс строки. IWriteSymbols := 0; // Кол-во вписанных символов. IStep := 1; // Шаг - кол-во вписываемых символов в одном направлении. IDirection := 0; // Направление: 1 - вверх, 2 - вправо, 3 - вниз, 4 - влево. IIncStep := -1; // Дельта шага. For i := 1 to Length(s) do. Begin. SgMatrix.Cells[c, r] := s[i]; // Визуализировать. If chAnimation.Checked then. Begin. Application.ProcessMessages; X := fmMain.Left + sgMatrix.Left + sgMatrix.CellRect(c, r).Left + iHalfCell; Y := fmMain.Top + sgMatrix.Top + sgMatrix.CellRect(c, r).Top + iHalfCell + GetSystemMetrics(SM_CYCAPTION); SetCursorPos(x, y); SgMatrix.Repaint; Sleep(30); End; Inc(iWriteSymbols); { Если кол-во символов, которые нужно вписывать в одном. Направлении, достигло предела - тогда нужно поворачивать }. If iWriteSymbols = iStep then. Begin. // Определим следующее направление. Inc(iDirection); If iDirection = 5 then. IDirection := 1; IWriteSymbols := 0; Inc(iIncStep); If iIncStep = 2 then. Begin. Inc(iStep); IIncStep := 0; End; End; // Определим следующую клетку для записи. Case iDirection of. 1: dec(r); 2: inc(c); 3: inc(r); 4: dec(c); End; End; // Вносим по спирали. End. Else // Вносим по строкам. Begin. I := 1; For r := 0 to sgMatrix.RowCount - 1 do. For c := 0 to sgMatrix.ColCount - 1 do. Begin. SgMatrix.Cells[c, r] := s[i]; Inc(i); // Визуализировать. If chAnimation.Checked then. Begin. Application.ProcessMessages; X := fmMain.Left + sgMatrix.Left + sgMatrix.CellRect(c, r).Left + iHalfCell; Y := fmMain.Top + sgMatrix.Top + sgMatrix.CellRect(c, r).Top + iHalfCell + GetSystemMetrics(SM_CYCAPTION); SetCursorPos(x, y); SgMatrix.Repaint; Sleep(30); End; End; End; SetCursorPos(pCursor.x, pCursor.y); End; Procedure TfmMain.btEncodeClick(Sender: TObject); Const. SMsgLengthCheck = 'Длина текста должна быть равна 121'; Var. S: string; Begin. S := Trim(edEncode.Text); If Length(s) <> 121 then. Begin. MessageDlg(sMsgLengthCheck, mtInformation, [mbOk], 0); Exit; End; EdDecode.Text := ''; ClearMatrix; WriteToMatrix(s, true); EdDecode.Text := ReadFromMatrix(false); End; Procedure TfmMain.btDecodeClick(Sender: TObject); Const. SMsgLengthCheck = 'Длина текста должна быть равна 121'; Var. S: string; Begin. S := Trim(edDecode.Text); If Length(s) <> 121 then. Begin. MessageDlg(sMsgLengthCheck, mtInformation, [mbOk], 0); Exit; End; EdEncode.Text := ''; ClearMatrix; WriteToMatrix(s, false); EdEncode.Text := ReadFromMatrix(true); End; // Очистит матрицу. Procedure TfmMain.ClearMatrix; Var. R, c: integer; Begin. For r := 0 to sgMatrix.RowCount - 1 do. For c := 0 to sgMatrix.ColCount - 1 do. SgMatrix.Cells[c, r] := ''; End; // Считываем из матрицы. Function TfmMain.ReadFromMatrix(bSpiralWriteMode: boolean): string; Var. C, r, i, iWriteSymbols, iStep, iDirection, iIncStep, x, y, iHalfCell: integer; PCursor: TPoint; SResult: string; Begin. SgMatrix.Selection := TGridRect(Rect(-1, -1, -1, -1)); GetCursorPos(pCursor); SResult := ''; IHalfCell := sgMatrix.DefaultColWidth div 2; // Половина ширины ячейки. If bSpiralWriteMode then. Begin. C := 5; // Индекс колонки. R := 5; // Индекс строки. IWriteSymbols := 0; // Кол-во вписанных символов. IStep := 1; // Шаг - кол-во вписываемых символов в одном направлении. IDirection := 0; // Направление: 1 - вверх, 2 - вправо, 3 - вниз, 4 - влево. IIncStep := -1; // Дельта шага. SResult := ''; // Символы из матрицы считываем по спирали, начиная с центра. For i := 1 to 121 do. Begin. SResult := sResult + sgMatrix.Cells[c, r]; SgMatrix.Cells[c, r] := ''; // Визуализировать. If chAnimation.Checked then. Begin. Application.ProcessMessages; X := fmMain.Left + sgMatrix.Left + sgMatrix.CellRect(c, r).Left + iHalfCell; Y := fmMain.Top + sgMatrix.Top + sgMatrix.CellRect(c, r).Top + iHalfCell + GetSystemMetrics(SM_CYCAPTION); SetCursorPos(x, y); SgMatrix.Repaint; Sleep(30); End; Inc(iWriteSymbols); { Если кол-во символов, которые нужно считать в одном. Направлении, достигло предела - тогда нужно поворачивать }. If iWriteSymbols = iStep then. Begin. // Определим следующее направление. Inc(iDirection); If iDirection = 5 then. IDirection := 1; IWriteSymbols := 0; Inc(iIncStep); If iIncStep = 2 then. Begin. Inc(iStep); IIncStep := 0; End; End; // Определим следующую клетку считывания. Case iDirection of. 1: dec(r); 2: inc(c); 3: inc(r); 4: dec(c); End; End; End. Else // Считываем по строкам. Begin. For r := 0 to sgMatrix.RowCount - 1 do. For c := 0 to sgMatrix.ColCount - 1 do. Begin. SResult := sResult + sgMatrix.Cells[c, r]; SgMatrix.Cells[c, r] := ''; // Визуализировать. If chAnimation.Checked then. Begin. Application.ProcessMessages; X := fmMain.Left + sgMatrix.Left + sgMatrix.CellRect(c, r).Left + iHalfCell; Y := fmMain.Top + sgMatrix.Top + sgMatrix.CellRect(c, r).Top + iHalfCell + GetSystemMetrics(SM_CYCAPTION); SetCursorPos(x, y); SgMatrix.Repaint; Sleep(30); End; End; End; Result := sResult; SetCursorPos(pCursor.x, pCursor.y); End; End.

©Drkb::04012.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Кодирование с помощью решетки

Автор: ___Nikolay.

Кодирование русского текста методом сдвига

Автор: ___Nikolay.

Code: Unit uMain; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ComCtrls, Spin; Type. TForm1 = class(TForm). Panel1: TPanel; MmText: TMemo; Label1: TLabel; SeN: TSpinEdit; Label2: TLabel; BtEncode: TButton; BtDecode: TButton; Procedure btEncodeClick(Sender: TObject); Private. { Private declarations }. Procedure Encode(bCode: boolean; n: integer); // Encode - ПРОЦЕДУРА. // bCode - зашифровать/расшифровать. // n - шаг смещения. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. // ПРОЦЕДУРА КОДИРОВАНИЯ. Procedure TForm1.Encode(bCode: boolean; n: integer); Const. SMsgRangeErr = 'Значение шага должно быть от %d до %d!'; // Крайние символы для кодирования. ChBigFirstLetter: char = 'А'; ChBigLastLetter: char = 'Я'; ChFirstLetter: char = 'а'; ChLastLetter: char = 'я'; Var. IMinOrd: integer; // Код символа с наименьшим кодом. IMaxOrd: integer; // Код символа с наибольшим кодом. I: integer; // Для фикла. ITempOrd: integer; // Код подставляемого символа. Ch: char; // Каждый символ текста. S: string; // Преобразуемый текст. Begin. // Проверка шага на диапазон допустимых значений. If (n > Ord(chBigLastLetter) - Ord(chBigFirstLetter)) or (n < 1) then. Begin. MessageDlg(Format(sMsgRangeErr, [1, Ord(chBigLastLetter) - Ord(chBigFirstLetter)]), mtError, [mbOk], 0); Exit; End; S := Trim(mmText.Text); If s <> '' then // Если есть текст. For i := 1 to Length(s) do // Проходит каждый символ. Begin. Ch := s[i]; // Если очередной символ нужно кодировать. If ch in [chBigFirstLetter .. chBigLastLetter] then // Заглавные буквы. Begin. IMinOrd := Ord(chBigFirstLetter); IMaxOrd := Ord(chBigLastLetter); End. Else. If ch in [chFirstLetter .. chLastLetter] then // Строчные буквы. Begin. IMinOrd := Ord(chFirstLetter); IMaxOrd := Ord(chLastLetter); End. Else // Символ кодировать не нужно. Continue; If bCode then // Закодировать. Begin. ITempOrd := Ord(ch) + n; // Получаем потенциальную позицию. If iMaxOrd - iTempOrd < 0 then // Если символ зашел за границу предельного. Ch := Chr(iMinOrd + abs(iMaxOrd - iTempOrd) - 1) // Возьмем символ с другого конца круга. Else // Если нет.. Ch := chr(iTempOrd); //..все нормально. End. Else // Раскодировать. Begin. ITempOrd := Ord(ch) - n; // Получаем потенциальную позицию. If iMinOrd - iTempOrd > 0 then // Если символ зашел за границу предельного. Ch := Chr(iMaxOrd - (iMinOrd - iTempOrd - 1)) // Возьмем символ с другого конца круга. Else // Если нет.. Ch := chr(iTempOrd); //..все нормально. End; S[i] := ch; End; MmText.Text := s; End; Procedure TForm1.btEncodeClick(Sender: TObject); Begin. Encode(boolean((Sender as TButton).Tag), seN.Value); End; End.

©Drkb::04011.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Кодировка полиалфавитным шифром Вигeнера

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Кодировка полиалфавитным шифром Вигенера - xor кодировка. Кодировка полиалфавитным шифром Вигенера - xor кодировка. Одна функция для кодирования и декодирования. Input - входная строка. При кодировании это незакодированная строка, При декодировнии это закодированная строка. Key - слово ключ один и тот же в обоих случаях. При совпадении символов во входной строке и. Строке ключе на выходе получается символ '#0'. Зависимости: Стандартные модули. Автор: Ru, DiVo_Ru@rambler.ru, Одесса. Copyright: DiVo 2002 creator Ru. Дата: 18 ноября 2002 г. ***************************************************** } Function VigenerCoDec(Input, Key: pchar): pchar. Var. I, j: integer; Tmps, text: string; Begin. Text := Input; For i := 1 to length(text) do. Begin. If i > length(key) then. J := i mod length(key). Else. J := i; Tmps := tmps + chr((ord(text[i])) xor (ord(key[j]))); End; Result := pchar(tmps); End; Пример использования: Text := edit1.text; K := edit2.text; Edit3.text := VigenerCoDec(Text, K); // Закодировать: Input := 'Привет я РУ'; Key := 'hello'; Result := 'ГуднйзНвН++'; // Восстановить: Input := 'ГуднйзНвН++'; Key := 'hello'; Result := 'Привет я РУ';

Кодировка полиалфавитным шифром Вигeнера

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Кодировка полиалфавитным шифром Вигенера - xor кодировка. Кодировка полиалфавитным шифром Вигенера - xor кодировка. Одна функция для кодирования и декодирования. Input - входная строка. При кодировании это незакодированная строка, при декодировнии это закодированная строка. Key - слово ключ один и тот же в обоих случаях. При совпадении символов во входной строке и строке ключе на выходе получается символ '#0'. Зависимости: Стандартные модули. Автор: Ru, DiVo_Ru@rambler.ru, Одесса. Copyright: DiVo 2002 creator Ru. Дата: 18 ноября 2002 г. ********************************************** } Function VigenerCoDec(Input,Key:pchar):pchar. Var. I,j:integer; Tmps,text:string; Begin. Text:=Input; For i:=1 to length(text) do. Begin. If i>length(key) then j:=i mod length(key) else j:=i; Tmps:=tmps+chr((ord(text[i]))xor(ord(key[j]))); End; Result:=pchar(tmps); End;

Кодовые потоки

16. Кодовые потоки.

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

16.1. Что такое поток?

Поток это ваш код исполняемый паралелльно с другим вашим кодом в одной программе. Использование потоков позволяет выполнять несколько задач одновременно.

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

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

Если процессоров несколько, то потоки реально могут выполняться параллельно, но все равно каждый процессор выполняет только один поток.

16.2. Достоинства потоков.

Использование потоков дает дополнительные преимущества перед обычным однопоточным дизайном.

16.2.1. Управление приоритетами (Prioritization).

Приоритеты отдельных потоков могут быть подстроены. Это позволяет отдельным серверным соединениям или клиентам получать больше процессорного времени.

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

В большинстве случае вместо повышения приоритета, вы можете уменьшать его. Это позволяет менее важным задачам не забирать слишком много времени от более важных задач.

Управление приоритетами потока также очень полезно на серверах и в некоторых случаях вы можете пожелать управлять приоритетом на основе логина. Если администратор подключается, то вы можете пожелать увеличить его приоритет, по сравнению с другими пользователями.

16.2.2. Инкапсуляция.

Использование потоков позволяет отделить каждую задачу от других, чтобы они меньше влияли друг на друга.

Если вы использовали Windows 3.1, то вы вероятно помните, как одно плохое приложение могло легко остановить всю систему. Потоки предотвращают подобное. Без потоков, все задачи должны были реализрваться в одном учвастке кода, создавая дополнительные сложности. С потоками, каждая задача может быть разделена на независимые секции, делая ваш код проще для программирования, когда требуется одновременное выполнение задач.

16.2.3. Безопасность.

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

16.2.4. Несколько процессоров.

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

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

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

16.2.5. Не нужна последовательность.

Потоки предоставляют подлинное параллельное выполнение. Без потоков все запросы должны выполняться в одном потоке. Для этого работа каждой задачи должна быть разделена на малые части которые можно быстро выполнить. Если любая часть блокируется или требует много времени для исполнения, то все остальные части должны быть задержаны, пока она не выполнится. После того как одна части выполнится, начинается выполнение другой и так далее.

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

16.3. Процессы против потоков.

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

16.4. Потоки против процессов.

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

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

16.5. Переменные потоков.

Переменные потока объявляются с использование ключевого слова ThreadVar.

Переменные потока подобны глобальным переменным и объявляются подобным образом. Различие в том, что обычная глобальная переменная является глобальной для всех потоков, а переменные потока специфичны для каждого потока. Так в каждом потоке, появляется свое собственное глобальное пространство.

Переменные потока могут быть полезны, когда трудно передавать ссылки на объект между библиотеками или изолированными кусками кода. Конечно переменные потока имеют и ограничения. Переменные потока не могут быть использованы или объявлены внутри пакетов. Везде где только возможно, должны быть использованы члены-переменные в классе потока. Они обеспечивают меньшую нагрузку и доступны для использования в пакетах.

16.6. Термины потоковый (threadable) и потоко-безопасный (threadsafe).

Термин потоко-безопасный (threadsafe) часто используется или трактуется неправильно. Его часто применяют одновременно к потоковый (threadable) и потоко-безопасный (threadsafe), что приводит к ошибкам. В данном тексте, термины потоковый и потоко-безопасный точно определены и имеют разное значение.

16.6.1. Термин потоковый (threadable).

Термин потоковый означает, что объект может использоваться внутри потока или использоваться потоком, если он должным образом защищен. Объект помечается как потоковый и обычно не имеет зависимости от потоков.

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

Примеры потоковых переменных – это значения типа Integer, String и другие ординарные типы, TList, TStringList и большинство невизуальных классов.

Объект может иметь доступ к глобальным переменным или элементам управления GUI. Неограниченное (а часто и не нужное) использование глобальных переменных в большинстве случаях, это то что мешает сделать компоненты потоковыми.

Объект может быть библиотекой, компонентом, процедурой или .

16.6.2. Термин потоко-безопасный (threadsafe).

Термин потоко-безопасный означает, что объект осведомлен о потоках и имеет внутреннюю свою защиту ресурсов. Потоко-безопасные значения объекты могут использоваться в одном или нескольких потоках без применения защиты ресурсов.

Примером потоко-безопасных классов является VCL класс TThreadList, а также потоко-безопасные классы Indy. Конечно операционная система также потоко-безопасна.

16.7. Синхронизация.

Синхронизация – это процесс передачи информации из вторичного потока основному. VCL поддерживает это с помощью метода Sychronize класса TThread.

16.8. Класс TThread.

Класс TThread это класс реализации потоков, который включен в VCL и предоставляет неплохую базу для построения потоков.

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

16.9. Компонент TThreadList.

Компонент TThreadList – это потоко-безопасная реализация класса TList. Класс TList может быть использован в любом количестве потоков без необходимости защиты от одновременного доступа.

Класс TThreadList работает подобно TList, но не совсем также. Некоторые методы, такие как as Add, Clear и Remove аналогичны. Для других операций, класс the TThreadList должен быть заблокирован с помощью метода LockList. метод LockList – это функции и она возвращает ссылку на внутренний экземпляр класса TList. Когда он заблокирован, все другие потоки будут заблокированы. По этому, очень важно разблокировать (Unlock) как можно быстрее.

Пример операций с TThreadList:

Code: With MyThreadList.LockList do. Try. T := Bytes div {/} KILOry. For i := 0 to Count - 1 do. Begin. // Operate on list items. Items[i] := Uppercase(Items[i]); End; Finally. MyThreadList.UnlockList; End;

Корректировка поведения маски TDateTimeField.

Автор: Виктор Светлов

Ловить события мышки вне вашего приложения

Code: Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, AppEvnts, StdCtrls; Type. TForm1 = class(TForm). ApplicationEvents1: TApplicationEvents; Button_StartJour: TButton; Button_StopJour: TButton; ListBox1: TListBox; Procedure ApplicationEvents1Message(var Msg: tagMSG; Var Handled: Boolean); Procedure Button_StartJourClick(Sender: TObject); Procedure Button_StopJourClick(Sender: TObject); Procedure FormClose(Sender: TObject; var Action: TCloseAction); Private. { Private declarations }. FHookStarted : Boolean; Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Var. JHook: THandle; // The JournalRecordProc hook procedure is an application-defined or library-defined callback. // function used with the SetWindowsHookEx function. // The function records messages the system removes from the system message queue. // A JournalRecordProc hook procedure does not need to live in a dynamic-link library. // A JournalRecordProc hook procedure can live in the application itself. // WH_JOURNALPLAYBACK Hook Function. //Syntax. // JournalPlaybackProc( // nCode: Integer; {a hook code}. // wParam: WPARAM; {this parameter is not used}. // lParam: LPARAM {a pointer to a TEventMsg structure}. // ): LRESULT; {returns a wait time in clock ticks}. Function JournalProc(Code, wParam: Integer; var EventStrut: TEventMsg): Integer; stdcall; Var. Char1: PChar; S: string; Begin. {this is the JournalRecordProc}. Result := CallNextHookEx(JHook, Code, wParam, Longint(@EventStrut)); {the CallNextHookEX is not really needed for journal hook since it it not. Really in a hook chain, but it's standard for a Hook}. If Code < 0 then Exit; {you should cancel operation if you get HC_SYSMODALON}. If Code = HC_SYSMODALON then Exit; If Code = HC_ACTION then. Begin. { The lParam parameter contains a pointer to a TEventMsg. Structure containing information on. The message removed from the system message queue. } S := ''; If EventStrut.message = WM_LBUTTONUP then. S := 'Left Mouse UP at X pos ' + IntToStr(EventStrut.paramL) + ' and Y pos ' + IntToStr(EventStrut.paramH); If EventStrut.message = WM_LBUTTONDOWN then. S := 'Left Mouse Down at X pos ' + IntToStr(EventStrut.paramL) + ' and Y pos ' + IntToStr(EventStrut.paramH); If EventStrut.message = WM_RBUTTONDOWN then. S := 'Right Mouse Down at X pos ' + IntToStr(EventStrut.paramL) + ' and Y pos ' + IntToStr(EventStrut.paramH); If (EventStrut.message = WM_RBUTTONUP) then. S := 'Right Mouse Up at X pos ' + IntToStr(EventStrut.paramL) + ' and Y pos ' + IntToStr(EventStrut.paramH); If (EventStrut.message = WM_MOUSEWHEEL) then. S := 'Mouse Wheel at X pos ' + IntToStr(EventStrut.paramL) + ' and Y pos ' + IntToStr(EventStrut.paramH); If (EventStrut.message = WM_MOUSEMOVE) then. S := 'Mouse Position at X:' + IntToStr(EventStrut.paramL) + ' and Y: ' + IntToStr(EventStrut.paramH); If s <> '' then. Form1.ListBox1.ItemIndex := Form1.ListBox1.Items.Add(s); End; End; Procedure TForm1.Button_StartJourClick(Sender: TObject); Begin. If FHookStarted then. Begin. ShowMessage('Mouse is already being Journaled, can not restart'); Exit; End; JHook := SetWindowsHookEx(WH_JOURNALRECORD, @JournalProc, hInstance, 0); {SetWindowsHookEx starts the Hook}. If JHook > 0 then. Begin. FHookStarted := True; End. Else. ShowMessage('No Journal Hook availible'); End; Procedure TForm1.Button_StopJourClick(Sender: TObject); Begin. FHookStarted := False; UnhookWindowsHookEx(JHook); JHook := 0; End; Procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG; Var Handled: Boolean); Begin. {the journal hook is automaticly camceled if the Task manager. (Ctrl-Alt-Del) or the Ctrl-Esc keys are pressed, you restart it. When the WM_CANCELJOURNAL is sent to the parent window, Application}. Handled := False; If (Msg.message = WM_CANCELJOURNAL) and FHookStarted then. JHook := SetWindowsHookEx(WH_JOURNALRECORD, @JournalProc, 0, 0); End; Procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); Begin. {make sure you unhook it if the app closes}. If FHookStarted then. UnhookWindowsHookEx(JHook); End; End.

Коды виртуальных клавиш

Code: Vk_LButton = $01; Vk_RButton = $02; Vk_Cancel = $03; Vk_MButton = $04; { генерятся только системой вместе с L & RBUTTON }. Vk_Back = $08; Vk_Tab = $09; Vk_Clear = $0C; Vk_Return = $0D; Vk_Shift = $10; Vk_Control = $11; Vk_Menu = $12; Vk_Pause = $13; Vk_Capital = $14; Vk_Escape = $1B; Vk_Space = $20; Vk_Prior = $21; Vk_Next = $22; Vk_End = $23; Vk_Home = $24; Vk_Left = $25; Vk_Up = $26; Vk_Right = $27; Vk_Down = $28; Vk_Select = $29; Vk_Print = $2A; Vk_Execute = $2B; Vk_SnapShot = $2C; { vk_Copy = $2C не используется клавиатурой }. Vk_Insert = $2D; Vk_Delete = $2E; Vk_Help = $2F; { vk_A - vk_Z такие же, как и их ASCII-эквиваленты: 'A' - 'Z' }. { vk_0 - vk_9 такие же, как и их ASCII-эквиваленты: '0' - '9' }. Vk_NumPad0 = $60; Vk_NumPad1 = $61; Vk_NumPad2 = $62; Vk_NumPad3 = $63; Vk_NumPad4 = $64; Vk_NumPad5 = $65; Vk_NumPad6 = $66; Vk_NumPad7 = $67; Vk_NumPad8 = $68; Vk_NumPad9 = $69; Vk_Multiply = $6A; Vk_Add = $6B; Vk_Separator = $6C; Vk_Subtract = $6D; Vk_Decimal = $6E; Vk_Divide = $6F; Vk_F1 = $70; Vk_F2 = $71; Vk_F3 = $72; Vk_F4 = $73; Vk_F5 = $74; Vk_F6 = $75; Vk_F7 = $76; Vk_F8 = $77; Vk_F9 = $78; Vk_F10 = $79; Vk_F11 = $7A; Vk_F12 = $7B; Vk_F13 = $7C; Vk_F14 = $7D; Vk_F15 = $7E; Vk_F16 = $7F; Vk_F17 = $80; Vk_F18 = $81; Vk_F19 = $82; Vk_F20 = $83; Vk_F21 = $84; Vk_F22 = $85; Vk_F23 = $86; Vk_F24 = $87; Vk_NumLock = $90; Vk_Scroll = $91;

Коды ответов HTTP сервера.

Коды ответов HTTP сервера

Успешные 200 OK 201 Created 202 Accepted 203 Non-Authoriative Information 204 No Content 205 Reset Content 206 Partial Content Перенаправляющие 300 Multiple Choices 301 Moved Permanently 302 Moved Temporarily 303 See Other 304 Not Modified 305 Use Proxy (proxy redirect) Клиентские ошибки 400 Bad Request 401 Unauthorized 402 Payment Required 403 Forbidden 404 Not Found 405 Method Not Allowed 406 Not Acceptable 407 Proxy Authentication Required 408 Request Timeout 409 Confict 410 Gone 411 Length Required 412 Precondition Failed 413 Request Entity To Large 414 Request-URI Too Long 415 Unsupported Media Type Ошибки сервера 500 Internal Server Error 501 Not Implemented 502 Bad Gateway 503 Service Unavailable 504 Gateway Timeout 505 HTTP Version Not Supported Дополнительная информация здесь: Hypertext Transfer Protocol -- HTTP/1.0.

Взято из http://forum.sources.ru.

Автор: Rouse_

©Drkb::03371.

Имена сетевого адаптера, системное имя устройства и описание.

Имена сетевого адаптера, системное имя устройства и описание

Имя виртуального устройства можно получить вот так:

Code: {©Drkb v.3(2007): www.drkb.ru}. Const. MAX_ADAPTER_NAME = 255; Type. PIP_ADAPTER_INDEX_MAP = ^IP_ADAPTER_INDEX_MAP; IP_ADAPTER_INDEX_MAP = record. Index: DWORD; Name: array [0..MAX_ADAPTER_NAME-1] of WideChar; End; PIP_INTERFACE_INFO = ^IP_INTERFACE_INFO; IP_INTERFACE_INFO = record. NumAdapters: Longint; Adapter: array [0..0] of IP_ADAPTER_INDEX_MAP; End; Function GetIfEntry(pIfRow: PMibIfRow): DWORD; stdcall external 'iphlpapi.dll'; Function GetNumberOfInterfaces(var pdwIntf: DWORD): DWORD; stdcall; external 'iphlpapi.dll'; Function GetInterfaceInfo(pIfTable: PIP_INTERFACE_INFO; var dwOutBufLen:DWORD): DWORD; Stdcall; external 'iphlpapi.dll'; Function GetAdapterIndex(AdapterName: PWideChar; var IfIndex: DWORD): DWORD; Stdcall; external 'iphlpapi.dll'; Procedure TMainForm.Button1Click(Sender: TObject); Var. I, pdwIntf, dwOutBufLen, IfIndex: DWORD; LpInfo: PIP_INTERFACE_INFO; MirIfDescr: TMibIfRow; Begin. //if GetNumberOfInterfaces(pdwIntf) = NO_ERROR then. //begin. GetInterfaceInfo(nil, dwOutBufLen); GetMem(lpInfo, dwOutBufLen); Try. If GetInterfaceInfo(lpInfo, dwOutBufLen) = NO_ERROR then. Begin. For I := 0 to lpInfo^.NumAdapters - 1 do. Begin. Memo1.Lines.Add('AdapterName: ' + lpInfo^.Adapter[I].Name); If GetAdapterIndex(lpInfo^.Adapter[I].Name, IfIndex) = NO_ERROR then. Memo1.Lines.Add('AdapterIndex: ' + IntToStr(IfIndex)). Else. RaiseLastOSError; ZeroMemory(@mirIfDescr, SizeOf(TMibIfRow)); MirIfDescr.dwIndex := IfIndex; If GetIfEntry(@mirIfDescr) = NO_ERROR then. Memo1.Lines.Add('AdapterDescription: ' + mirIfDescr.bDescr). Else. RaiseLastOSError; End; End. Else. RaiseLastOSError; Finally. FreeMem(lpInfo); End; End. //else. //RaiseLastOSError; End;

Взято из http://forum.sources.ru.

Автор: Rouse_

©Drkb::03323.

Количество уникальных цветов Bitmap.

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Функция возвращает колличество уникальных цветов Bitmap. Зависимости: Graphics. Автор: Fenik, chook_nu@uraltc.ru, Новоуральск. Copyright: Собственное написание (Николай федоровских). Дата: 1 июня 2002 г. ***************************************************** } Function HowManyColors(Bitmap: TBitmap): Integer; Type. TRGB = record. B, G, R: Byte; End; PRGB = ^TRGB; Var. I: Byte; X, y: Integer; Dest: pRGB; RGBArray: array[0..255, 0..255] of array of Byte; Begin. Bitmap.PixelFormat := pf24Bit; Result := 0; For y := 0 to Bitmap.Height - 1 do. Begin. Dest := Bitmap.ScanLine[y]; For x := 0 to Bitmap.Width - 1 do. Begin. With Dest^ do. If RGBArray[r, g] <> nil then. For i := 0 to High(RGBArray[r, g]) do. Begin. //если такой цвет уже есть, то выходим из цыкла. If RGBArray[r, g][i] = b then. Break; //если это последний круг цикла, то такого цвета нет. If i = High(RGBArray[r, g]) then. Begin. Inc(Result); //прибавляем один цвет. SetLength(RGBArray[r, g], Length(RGBArray[r, g]) + 1); RGBArray[r, g][High(RGBArray[r, g])] := b; End; End. Else. Begin. Inc(Result); SetLength(RGBArray[r, g], 1); RGBArray[r, g][0] := b; End; Inc(Dest); End; End; End;

Имитация ввода с клавиатуры для консоли

Автор: Nomadic.

Имитация Tab.

Code: SelectNext(screen.ActiveControl, True, True);

Конвертирование числа в строку которую понимает Excel.

Code: /* Функция переводит число в строковое выражение числа с запятой, которое понимает Ёксель. *P* 15.11.02 */ CREATE FUNCTION Float2Str. (@val as float ). RETURNS varchar(24). AS. BEGIN. Declare @s as varchar(24). Set @s=str(@val,21,2). Return stuff(@s,len(@s)-2,1,','). END.

Координатная сетка

Code: Unit grid_; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Procedure FormPaint(Sender: TObject); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. {$R *.DFM}. Procedure TForm1.FormPaint(Sender: TObject); Var. X0, y0: integer; // координаты начала координатных осей. Dx, dy: integer; // шаг координатной сетки (в пикселях). H, w: integer; // высота и ширина области вывода координатной сетки. X, y: integer; Lx, ly: real; // метки (оцифровка) линий сетки по X Y. Dlx, dly: real; // шаг меток (оцифровки) линий сетки по X и Y. Cross: integer; // счетчик не оцифрованных линий сетки. Dcross: integer; // количество не оцифрованных линий между оцифрованными. Begin. X0 := 30; Y0 := 220; // оси начинаются в точке (40,250). Dx := 40; Dy := 40; // шаг координатной сетки 40 пикселей. Dcross := 1; // помечать линии сетки X: 1 - каждую; // 2 - через одну; // 3 - через две; Dlx := 0.5; // шаг меток оси X. Dly := 1.0; // шаг меток оси Y, метками будут: 1, 2, 3 и т.д. H := 200; W := 300; With form1.Canvas do. Begin. Cross := dcross; MoveTo(x0, y0); LineTo(x0, y0 - h); // ось X. MoveTo(x0, y0); LineTo(x0 + w, y0); // ось Y. // засечки, сетка и оцифровка по оси X. X := x0 + dx; Lx := dlx; Repeat. MoveTo(x, y0 - 3); LineTo(x, y0 + 3); // засечка. Cross := cross - 1; If cross = 0 then //оцифровка. Begin. TextOut(x - 8, y0 + 5, FloatToStr(lx)); Cross := dcross; End; Pen.Style := psDot; MoveTo(x, y0 - 3); LineTo(x, y0 - h); // линия сетки. Pen.Style := psSolid; Lx := lx + dlx; X := x + dx; Until (x > x0 + w); // засечки, сетка и оцифровка по оси Y. Y := y0 - dy; Ly := dly; Repeat. MoveTo(x0 - 3, y); LineTo(x0 + 3, y); // засечка. TextOut(x0 - 20, y, FloatToStr(ly)); // оцифровка. Pen.Style := psDot; MoveTo(x0 + 3, y); LineTo(x0 + w, y); // линия сетки. Pen.Style := psSolid; Y := y - dy; Ly := ly + dly; Until (y < y0 - h); End; End; End.

Копирование большого файла в буфер обмена

Вот общее решение, которое будет работать, даже если у вас размер файла превышает 64Кб:

Копирование в буфер обмена

Code: Procedure CopyButtonClick(Sender: TObject); Begin. If ActiveControl is TMemo then. TMemo(ActiveControl).CopyToClipboard; If ActiveControl is TDBMemo then. TDBMemo(ActiveControl).CopyToClipboard; If ActiveControl is TEdit then. TEdit(ActiveControl).CopyToClipboard; If ActiveControl is TDBedit then. TDBedit(ActiveControl).CopyToClipboard; End; Procedure PasteButtonClick(Sender: TObject); Begin. If ActiveControl is TMemo then. TMemo(ActiveControl).PasteFromClipboard; If ActiveControl is TDBMemo then. TDBMemo(ActiveControl).PasteFromClipboard; If ActiveControl is TEdit then. TEdit(ActiveControl).PasteFromClipboard; If ActiveControl is TDBedit then. TDBedit(ActiveControl).PasteFromClipboard; End;

Копирование и вставка данных своего формата из буфера обмена

Code: // The TClipboard provides easy clipboard access. But what if you. // want to add (several) custom defined items to the clipboard? // For all actions is the unit Clipboard required. Uses Clipboard; // First you have to register your own ClipBoard format. // Zuerst registrieren wir unser eigenes ClipBoard Format. Const. MyClipboardFormatStr = 'MyData'; Var. MyClpFormat: integer; MyClpFormat := RegisterClipboardFormat(MyClipboardFormatStr); { The variable SLMClpFormat will contain a unique format handle for. Your own clipboard format. Die Variable SLMClpFormat enthalt ein einzigartiges Format Handle. Fur unser ClipBoard Format. } Procedure IncPointer(var p: Pointer; increment: Integer); Begin. P := PChar(p) + Increment; End; // Say you have a data record defined as: // Definiere zuerst etwa einen solchen Daten Record: Type. PMyDataRec = ^TMyDataRec; TMyDataRec = record. Name: string[50]; Value: Integer; End; { Furthermore let's say the data records are stored in a Listbox. And shall be copied to a list box. Angenommen, die Daten Records sind in einer ListBox gespeichert und. Sollen in eine ListBox kopiert werden. } // Copy like this: Procedure TForm1.CopyItems; Var. I: integer; Dh: THandle; Ic: integer; P: Pointer; Pi: pInteger; Begin. // get number of items to be copied. // Die Anzahl zu kopierenden Items. Ic := List1.SelCount; Dh := GlobalAlloc(GMEM_FIXED or GMEM_ZEROINIT, (SizeOf(TMyDataRec) * ic) + SizeOf(Integer)); { allocate memory for all items plus for a integer variable giving you the number of. Copied items }. P := GlobalLock(dh); { Lock the allocated memory }. Pi := pInteger(p); Pi^ := ic; { write number of items to allocated memory }. IncPointer(p, SizeOf(Integer)); { increment the pointer behind the written data }. // You don't have to create an instance of clipboard, this is done automatically. For i := 1 to List1.Items.Count do { check all items if they are selected }. Begin. If List1.Items[i - 1].Selected then. Begin. { This one is selected -> copy it o the clipboard }. PMyDataRec(p)^ := PMyDataRec(List1.Items[i - 1].Data)^; { of course data must point to a TMyDataRec }. IncPointer(p, SizeOf(TMyDataRec)); { increment the pointer behind the written data }. End; End; // You have now filled the allocated memory with all items that shall be copied. // Now you can put them to the clipboard. Clipboard.Open; { Open the clipboard will prevent overwriting of so far copied items }. Clipboard.Clear; { Clear the clipboard first }. Clipboard.SetAsHandle(MyClpFormat, Dh); { Copy to clipboard }. Clipboard.Close; { finally close the clipboard }. GlobalUnlock(dh); { and unlock the allocate memory. But don't free it, it will be used by the clipboard }. If ic = 0 then. GlobalFree(dh); { You can free it if you haven't copied anything }. End; // Check first if your items are still available before pasting them from the clipbard. If Clipboard.HasFormat(MyClpFormat) then. Begin. Form1.Paste1.Enabled := True; { Yes, they are still available }. End; // And this is, how you paste them after Paste1 is clicked. Procedure TMDIForm.Paste1Click(Sender: TObject); Var. Dh: THandle; Pdr: PSLMDataRec; I, ic: integer; P: Pointer; Pi: pInteger; Li: TListItem; Begin. If Clipboard.HasFormat(MyClpFormat) then. // We have already checked, but maybe another application has overwritten the. // clipboard in between.... Begin. ClipBoard.Open; { First open the clipboard again }. Dh := Clipboard.GetAsHandle(MyClpFormat); { Catch the handle to the stored items }. P := GlobalLock(dh); { and lock it }. Pi := pInteger(p); { The first item is an integer giving the number of items }. Ic := pi^; { so get the number of items }. IncPointer(p, SizeOf(Integer)); { increment the pointer behind the read data }. For i := 1 to ic do { get all copied items one after another }. Begin. Li := List1.Items.Add; { first create a new listbox item }. Pdr := New(PMyDataRec); { Then create a new pointer to a TMyDataRec }. Pdr^ := PMyDataRec(p)^; { and fill it with data from the clipboard }. IncPointer(p, SizeOf(TSLMDataRec)); { increment the pointer behind the written data }. Li.Data := pdr; { Set the data pointer of the list item to the new record }. LI.Caption := pdr^.Name; { Let the item display the record field "Name" }. // You can of course add more record fields if the item has subitems: LI.SubItems.Add(IntToStr(Value)); End; { All data retrieved from clipboard }. Clipboard.Close; { Close it }. GlobalUnlock(dh); { and unlock the pointer, but don't free it. This will be done by the clipboard itself, If necessary }. End; End;

©Drkb::01917.

Взято с сайта: http://www.swissdelphicenter.ch.

Копирование потока компонент в буфер обмена

Code: { Clipboard has methods GetComponent and SetComponent but we need. To stream multiple components to the clipboard to include copy paste type. Of feature. } Procedure CopyStreamToClipboard(fmt: Cardinal; S: TStream); Var. HMem: THandle; PMem: Pointer; Begin. S.Position := 0; HMem := GlobalAlloc(GHND or GMEM_DDESHARE, S.Size); If hMem <> 0 then. Begin. PMem := GlobalLock(hMem); If pMem <> nil then. Begin. S.Read(pMem^, S.Size); S.Position := 0; GlobalUnlock(hMem); Clipboard.Open; Try. Clipboard.SetAsHandle(fmt, hMem); Finally. Clipboard.Close; End; End { If }. Else. Begin. GlobalFree(hMem); OutOfMemoryError; End; End { If }. Else. OutOfMemoryError; End; { CopyStreamToClipboard }.

Копирование свойств одного компонента другому

Code: Uses. StrUtils; Procedure CopyComponentProp(Source, Target: TObject; aExcept: array of string); // Копирование всех одинаковых по названию свойств/методов одного компонента в. // другой за исключение "Name", "Left", "Top" и тех которые заданы в aExcept. // Примеры использования: // CopyComponentProp(N11, N21, []); // CopyComponentProp(ListBox2, ListBox3, []); // CopyComponentProp(ListView1, ListView2, ['Items', 'Color']); Var. I, Index: Integer; PropName: string; Source_PropList , Target_PropList : PPropList; Source_NumProps , Target_NumProps : Word; Source_PropObject, Target_PropObject: TObject; // Поиск в списке свойства с заданным именем. Function FindProperty(const PropName: string; PropList: PPropList; NumProps: Word): Integer; Var. I: Integer; Begin. Result:= -1; For I:= 0 to NumProps - 1 do. If CompareStr(PropList^[I]^.Name, PropName) = 0 then begin. Result:= I; Break; End; End; Begin. If not Assigned(Source) or not Assigned(Target) then Exit; Source_NumProps:= GetTypeData(Source.ClassInfo)^.PropCount; Target_NumProps:= GetTypeData(Target.ClassInfo)^.PropCount; GetMem(Source_PropList, Source_NumProps * SizeOf(Pointer)); GetMem(Target_PropList, Target_NumProps * SizeOf(Pointer)); Try. // Получаем список свойств. GetPropInfos(Source.ClassInfo, Source_PropList); GetPropInfos(Target.ClassInfo, Target_PropList); For I:= 0 to Source_NumProps - 1 do begin. PropName:= Source_PropList^[I]^.Name; If (AnsiIndexText('None' , aExcept ) = -1) and. ((AnsiIndexText(PropName, ['Name', 'Left', 'Top']) <> -1) or. (AnsiIndexText(PropName, aExcept ) <> -1)) then Continue; Index:= FindProperty(PropName, Target_PropList, Target_NumProps); If Index = -1 then Continue; // не нашли. // Проверить совпадение типов. If Source_PropList^[I]^.PropType^.Kind <> Target_PropList^[Index]^.PropType^.Kind then. Continue; Case Source_PropList^[I]^.PropType^^.Kind of. TkClass: begin. Source_PropObject:= GetObjectProp(Source, Source_PropList^[I ]); Target_PropObject:= GetObjectProp(Target, Target_PropList^[Index]); CopyComponentProp(Source_PropObject, Target_PropObject, ['None']); End; TkMethod: SetMethodProp(Target, PropName, GetMethodProp(Source, PropName)); Else. SetPropValue(Target, PropName, GetPropValue(Source, PropName)); End; End; Finally. FreeMem(Source_PropList); FreeMem(Target_PropList); End; End;

Копирование содержимого TStringGrid в буфер обмена

Code: { **** UBPFD *********** by delphibase.endimus.com **** >> Копирование содержимого StringGrid в буфер обмена. Копирует содержимое ячеек StringGrid в ClipBoard в формате, позволяющем. Вставку, например, в Word или Excel. При CopySel=True копирует выделение, Иначе всю таблицу или указанный диапазон (CL- левый столбец и т.д.). Зависимости: Grids. Автор: Борис Новгородов (MBo), mbo@mail.ru, Новосибирск. Copyright: MBo. Дата: 30 апреля 2002 г. ***************************************************** } Procedure SGCopyToCLP(SG: TStringGrid; CopySel: Boolean; CL: integer = -1; RT: integer = -1; CR: integer = -1; RB: integer = -1); Var. I, j: Integer; S: string; Begin. S := ''; With SG do. Begin. If CopySel then. Begin. CL := Selection.Left; CR := Selection.Right; RT := Selection.Top; RB := Selection.Bottom; End; //при необходимости FixedRows и FixedCols можно заменить на 0. If (CL < FixedCols) or (CL > CR) or (CL >= ColCount) then. CL := FixedCols; If (CR < FixedCols) or (CL > CR) or (CR >= ColCount) then. CR := ColCount - 1; If (RT < FixedRows) or (RT > RB) or (RT >= RowCount) then. RT := FixedRows; If (RB < FixedCols) or (RT > RB) or (RB >= RowCount) then. RB := RowCount - 1; For i := RT to RB do. Begin. For j := CL to CR do. Begin. S := s + Cells[j, i]; If j < CR then. S := s + #9; End; S := s + #13#10; End; End; ClipBoard.AsText := s; End; // Пример использования: SGCopyToCLP(StringGrid1, True); //выделение. SGCopyToCLP(StringGrid1, False); //все ячейки. SGCopyToCLP(StringGrid1, False, 1, 1, 3, 2); //диапазон, 6 ячеек.

Копирование содержимого экрана на форму

Code: Var. Image3: TImage; Procedure TSaverForm.CopyScreen; Var. DeskTopDC: HDc; DeskTopCanvas: TCanvas; DeskTopRect: TRect; Begin. Image3 := TImage.Create(SaverForm); With Image3 do. Begin. Height := Screen.Height; Width := Screen.Width; End; Image3.Canvas.copymode := cmSrcCopy; DeskTopDC := GetWindowDC(GetDeskTopWindow); DeskTopCanvas := TCanvas.Create; DeskTopCanvas.Handle := DeskTopDC; Image3.Canvas.CopyRect(Image3.Canvas.ClipRect, DeskTopCanvas, DeskTopCanvas.ClipRect); Image2.Picture.Assign(Image3.Picture); {image2 расположен на целевой форме и выровнен по области клиента}. End; Procedure TSaverForm.FormClose(Sender: TObject; var Action: TCloseAction); Begin. Image3.Free; End;

Копировать векторное изображение

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. Mf: TMetaFile; Mfc: TMetaFileCanvas; I: integer; ClipBrdFormat: word; Data: cardinal; Palette: hPalette; P: array [0..90] of TPoint; Begin. Mf := TMetaFile.Create; Mf.Width := 100; Mf.Height := 100; Mfc := TMetafileCanvas.Create(mf, 0); With mfc do. Begin. Pen.Color := clBlack; FrameRect(ClipRect); MoveTo(0, 50); LineTo(100, 50); LineTo(95, 48); MoveTo(100, 50); LineTo(95, 52); MoveTo(50, 100); LineTo(50, 0); LineTo(48, 5); MoveTo(50, 0); LineTo(52, 5); Brush.Style := bsClear; Font.name := 'arial'; Font.Size := 6; TextOut(55, 0, 'Y'); TextOut(95, 38, 'X'); Pen.Color := clRed; For i := low(p) to high(p) do. P[i] := Point(i, round(50 - 30 * sin((i - 50) / 5))); Polyline(p); End; Mfc.Free; Mf.SaveToClipboardFormat(ClipBrdFormat, data, palette); OpenClipboard(Application.Handle); EmptyClipboard; SetClipboardData(ClipBrdFormat, data); CloseClipboard; Mf.Inch := 200; Form1.Canvas.Draw(0, 0, mf); Mf.Free; End;

Копировать буфер в поток и обратно

Code: Uses. Clipbrd; Procedure CopyStreamToClipboard(fmt: Cardinal; S: TStream); Var. HMem: THandle; PMem: Pointer; Begin. Assert(Assigned(S)); S.Position := 0; HMem := GlobalAlloc(GHND or GMEM_DDESHARE, S.Size); If hMem <> 0 then. Begin. PMem := GlobalLock(hMem); If pMem <> nil then. Begin. Try. S.Read(pMem^, S.Size); S.Position := 0; Finally. GlobalUnlock(hMem); End; Clipboard.Open; Try. Clipboard.SetAsHandle(fmt, hMem); Finally. Clipboard.Close; End; End { If }. Else. Begin. GlobalFree(hMem); OutOfMemoryError; End; End { If }. Else. OutOfMemoryError; End; { CopyStreamToClipboard }. Procedure CopyStreamFromClipboard(fmt: Cardinal; S: TStream); Var. HMem: THandle; PMem: Pointer; Begin. Assert(Assigned(S)); HMem := Clipboard.GetAsHandle(fmt); If hMem <> 0 then. Begin. PMem := GlobalLock(hMem); If pMem <> nil then. Begin. Try. S.Write(pMem^, GlobalSize(hMem)); S.Position := 0; Finally. GlobalUnlock(hMem); End; End { If }. Else. Raise Exception.Create('CopyStreamFromClipboard: could not lock global handle ' + 'obtained from clipboard!'); End; { If }. End; { CopyStreamFromClipboard }. Procedure SaveClipboardFormat(fmt: Word; writer: TWriter); Var. Fmtname: array[0..128] of Char; Ms: TMemoryStream; Begin. Assert(Assigned(writer)); If 0 = GetClipboardFormatName(fmt, fmtname, SizeOf(fmtname)) then. Fmtname[0] := #0; Ms := TMemoryStream.Create; Try. CopyStreamFromClipboard(fmt, ms); If ms.Size > 0 then. Begin. Writer.WriteInteger(fmt); Writer.WriteString(fmtname); Writer.WriteInteger(ms.Size); Writer.Write(ms.Memory^, ms.Size); End; { If }. Finally. Ms.Free. End; { Finally }. End; { SaveClipboardFormat }. Procedure LoadClipboardFormat(reader: TReader); Var. Fmt: Integer; Fmtname: string; Size: Integer; Ms: TMemoryStream; Begin. Assert(Assigned(reader)); Fmt := reader.ReadInteger; Fmtname := reader.ReadString; Size := reader.ReadInteger; Ms := TMemoryStream.Create; Try. Ms.Size := Size; Reader.Read(ms.memory^, Size); If Length(fmtname) > 0 then. Fmt := RegisterCLipboardFormat(PChar(fmtname)); If fmt <> 0 then. CopyStreamToClipboard(fmt, ms); Finally. Ms.Free; End; { Finally }. End; { LoadClipboardFormat }. Procedure SaveClipboard(S: TStream); Var. Writer: TWriter; I: Integer; Begin. Assert(Assigned(S)); Writer := TWriter.Create(S, 4096); Try. Clipboard.Open; Try. Writer.WriteListBegin; For i := 0 to Clipboard.formatcount - 1 do. SaveClipboardFormat(Clipboard.Formats[i], writer); Writer.WriteListEnd; Finally. Clipboard.Close; End; { Finally }. Finally. Writer.Free. End; { Finally }. End; { SaveClipboard }. Procedure LoadClipboard(S: TStream); Var. Reader: TReader; Begin. Assert(Assigned(S)); Reader := TReader.Create(S, 4096); Try. Clipboard.Open; Try. Clipboard.Clear; Reader.ReadListBegin; While not reader.EndOfList do. LoadClipboardFormat(reader); Reader.ReadListEnd; Finally. Clipboard.Close; End; { Finally }. Finally. Reader.Free. End; { Finally }. End; { LoadClipboard }. // Examples: { Save Clipboard }. Procedure TForm1.Button1Click(Sender: TObject); Var. Ms: TMemoryStream; Begin. Ms := TMemoryStream.Create; Try. SaveClipboard(ms); Ms.SaveToFile('c:\temp\ClipBrdSaved.dat'); Finally. Ms.Free; End; { Finally }. End; { Clear Clipboard }. Procedure TForm1.Button2Click(Sender: TObject); Begin. Clipboard.Clear; End; { Restore Clipboard }. Procedure TForm1.Button3Click(Sender: TObject); Var. Fs: TfileStream; Begin. Fs := TFilestream.Create('c:\temp\ClipBrdSaved.dat', Fmopenread or fmsharedenynone); Try. LoadClipboard(fs); Finally. Fs.Free; End; { Finally }. End;

Копировать и вставлять ячейки TStringGrid в буфер обмена

Code: Uses. Clipbrd; //Copy. Procedure TForm1.Button1Click(Sender: TObject); Var. S: string; GRect: TGridRect; C, R: Integer; Begin. GRect := StringGrid1.Selection; S := ''; For R := GRect.Top to GRect.Bottom do. Begin. For C := GRect.Left to GRect.Right do. Begin. If C = GRect.Right then S := S + (StringGrid1.Cells[C, R]). Else. S := S + StringGrid1.Cells[C, R] + #9; End; S := S + #13#10; End; ClipBoard.AsText := S; End; // Paste. Procedure TForm1.Button2Click(Sender: TObject); Var. Grect: TGridRect; S, CS, F: string; L, R, C: Byte; Begin. GRect := StringGrid1.Selection; L := GRect.Left; R := GRect.Top; S := ClipBoard.AsText; R := R - 1; While Pos(#13, S) > 0 do. Begin. R := R + 1; C := L - 1; CS := Copy(S, 1,Pos(#13, S)); While Pos(#9, CS) > 0 do. Begin. C := C + 1; If (C <= StringGrid1.ColCount - 1) and (R <= StringGrid1.RowCount - 1) then. StringGrid1.Cells[C, R] := Copy(CS, 1,Pos(#9, CS) - 1); F := Copy(CS, 1,Pos(#9, CS) - 1); Delete(CS, 1,Pos(#9, CS)); End; If (C <= StringGrid1.ColCount - 1) and (R <= StringGrid1.RowCount - 1) then. StringGrid1.Cells[C + 1,R] := Copy(CS, 1,Pos(#13, CS) - 1); Delete(S, 1,Pos(#13, S)); If Copy(S, 1,1) = #10 then. Delete(S, 1,1); End; End;

©Drkb::01886.

Взято с сайта: http://www.swissdelphicenter.ch.

Копировать и вставлять TreeNode.

Code: Var. SL : TStringList; Procedure TForm1.CutBtnClick(Sender: TObject); Var. I, j, StartLevel : integer; TNSel : TTreeNode; Begin. TNSel := TreeView1.Selected; If TNSel <> nil then begin. StartLevel := TNSel.Level; I := TNSel.AbsoluteIndex; J := i; // note for later deletion. If SL = nil then. SL := TStringList.Create. Else. SL.Clear; SL.AddObject(TNSel.Text, pointer(0)); Inc(i); With TreeView1 do begin. While Items[i].Level > StartLevel do begin. {stop before next sibling to top node\}. SL.AddObject(Items[i].Text, pointer(Items[i].Level - StartLevel)); Inc(i); End; {while Items[i].Level > StartLevel\}. Items[j].Delete; End; {with TreeView1\}. End; {if TNSel <> nil\}. End; Procedure TForm1.PasteBtnClick(Sender: TObject); Var. I, Level : integer; TNSel, TN : TTreeNode; Begin. With TreeView1 do begin. TNSel := Selected; If TNSel <> nil then begin. TN := Items.Insert(TNSel, SL.Strings[0]); Level := integer(SL.Objects[0]); // should be 0. For i := 1 to SL.Count - 1 do begin. If integer(SL.Objects[i]) < Level then begin. {go up one level\}. TN := TN.Parent; Level := integer(SL.Objects[i]); End; {if integer(SL.Objects[i]) < Level\}. If Level = integer(SL.Objects[i]) then. {same level\}. TN := Items.Add(TN, SL.Strings[i]). Else begin. {go down one level\}. TN := Items.AddChild(TN, SL.Strings[i]); Level := integer(SL.Objects[i]); End; {if Level = integer(SL.Objects[i])\}. End; {for i := 1 to SL.Count - 1\}. End; {if TNSel <> nil\}. End; {with TreeView1\}. End;

Копировать узлы с поддеревом TTreeView во второй TTreeView.

Code: {type. {: Callback to use to copy the data of a treenode when the. Node itself is copied by CopySubtree. @param oldnode is the old node. @param newnode is the new node. @Desc Use a callback of this type to implement your own algorithm. For a node copy. The default just uses the Assign method, which. Produces a shallow copy of the nodes Data property. }. TCopyDataProc = procedure(oldnode, newnode : TTreenode); {: The default operation is to do a shallow copy of the node, via. Assign. }. Procedure DefaultCopyDataProc(oldnode, newnode : TTreenode); Begin. Newnode.Assign(oldnode); End; {-- CopySubtree. -------------------------------------------------------} {: Copies the source node with all child nodes to the target treeview. @Param sourcenode is the node to copy. @Param target is the treeview to insert the copied nodes into. @Param targetnode is the node to insert the copy under, can be nil to. Make the copy a top-level node. @Param CopyProc is the (optional) callback to use to copy a node. If Nil is passed for this parameter theDefaultCopyDataProc will be. Used. @Precondition sourcenode <> nil, target <> nil, targetnode is either. Nil or a node of target. @Raises Exception if targetnode happens to be in the subtree rooted in. Sourcenode. Handling that special case is rather complicated, so we. Simply refuse to do it at the moment. }{ Created 2003-04-09 by P. Below ----------------------------------------------------------------------- } Procedure CopySubtree(sourcenode : TTreenode; target : TTreeview; Targetnode : TTreenode; CopyProc : TCopyDataProc = nil); Var. Anchor : TTreenode; Child : TTreenode; Begin { CopySubtree }. Assert(Assigned(sourcenode), 'CopySubtree:sourcenode cannot be nil'); Assert(Assigned(target), 'CopySubtree: target treeview cannot be nil'); Assert((targetnode = nil) or (targetnode.TreeView = target), 'CopySubtree: targetnode has to be a node in the target treeview.'); If (sourcenode.TreeView = target) and. (targetnode.HasAsParent(sourcenode) or (sourcenode = Targetnode)) then. Raise Exception.Create('CopySubtree cannot copy a subtree to one of the ' + 'subtrees nodes.'); If not Assigned(CopyProc) then. CopyProc := DefaultCopyDataProc; Anchor := target.Items.AddChild(targetnode, sourcenode.Text); CopyProc(sourcenode, anchor); Child := sourcenode.GetFirstChild; While Assigned(child) do. Begin. CopySubtree(child, target, anchor, CopyProc); Child := child.getNextSibling; End; { While }. End; { CopySubtree }. Procedure TForm1.Button1Click(Sender : TObject); Begin. If assigned(treeview1.selected) then. CopySubtree(treeview1.selected, treeview2, nil); End;

Копировать RTF-текст в буфер обмена

Code: { You have to dig into the Rich Text Format if you want to copy text to the. Clipboard that has format information embedded. The application you paste. This text into has to understand RTF, or the formatting will not show up. OK, the first step is to register a clipboard format for RTF, since this is. Not a predefined format: } Var. CF_RTF : Word; CF_RTF := RegisterClipboardFormat('Rich Text Format'); { The format name has to appear as typed above, this is the name used by MS. Word for Windows and similar MS products. NOTE: The Richedit Unit declares a constant CF_RTF, which is NOT the. Clipboard format handle but the string you need to pass to RegisterClipboard. Format! So you can place Richedit into your uses clause and change the line. Above to. } CF_RTF := RegisterClipboardFormat(Richedit.CF_RTF); { The next step is to build a RTF string with the embedded format information. You will get a shock if you inspect the mess of RTF stuff W4W will put into. The clipboard if you copy just a few characters (the app below allows you to. Inspect the clipboard), but you can get away with a lot less. The bare. Minimum would be something like this (inserts an underlined 44444): } Const. Testtext: PChar = '{\rtf1\ansi\pard\plain 12{\ul 44444}}'; { The correct balance of opening and closing braces is extremely important, one. Mismatch and the target app will not be able to interpret the text. Correctly. If you want to control the font used for the pasted text you need. To add a fonttable (the default font is Tms Rmn, not the active font in the. Target app!). See example app below, testtext2. If you want more info, the. Full RTF specs can be found on www.microsoft.com, a subset is also described. In the Windows help compiler docs (hcw.hlp, comes with Delphi). } Unit Clipfmt1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). MemFormats: TMemo; Label1: TLabel; BtnShowFormats: TButton; BtnGetRTF: TButton; BtnSetRTF: TButton; MemExample: TMemo; Procedure FormCreate(Sender: TObject); Procedure BtnShowFormatsClick(Sender: TObject); Procedure BtnGetRTFClick(Sender: TObject); Procedure BtnSetRTFClick(Sender: TObject); Private. Public. CF_RTF: Word; End; Var. Form1: TForm1; Implementation. Uses Clipbrd; {$R *.DFM}. Procedure TForm1.FormCreate(Sender: TObject); Begin. // register clipboard format rtf. CF_RTF := RegisterClipboardFormat('Rich Text Format'); If CF_RTF = 0 then. Begin. ShowMessage('Unable to register the Rich Text clipboard format!'); Application.Terminate; End; BtnShowFormats.Click; End; // show clipboard formats. Procedure TForm1.BtnShowFormatsClick(Sender: TObject); Var. Buf: array [0..60] of Char; N: Integer; Fmt: Word; Name: string[30]; Begin. MemFormats.Clear; For n := 0 to Clipboard.FormatCount - 1 do. Begin. Fmt := Clipboard.Formats[n]; If GetClipboardFormatName(fmt, buf, Pred(SizeOf(buf))) <> 0 then. MemFormats.Lines.Add(StrPas(buf)). Else. Begin. Case fmt of. 1: Name := 'CF_TEXT'; 2: Name := 'CF_BITMAP'; 3: Name := 'CF_METAFILEPICT'; 4: Name := 'CF_SYLK'; 5: Name := 'CF_DIF'; 6: Name := 'CF_TIFF'; 7: Name := 'CF_OEMTEXT'; 8: Name := 'CF_DIB'; 9: Name := 'CF_PALETTE'; 10: Name := 'CF_PENDATA'; 11: Name := 'CF_RIFF'; 12: Name := 'CF_WAVE'; 13: Name := 'CF_UNICODETEXT'; 14: Name := 'CF_ENHMETAFILE'; 15: Name := 'CF_HDROP (Win 95)'; 16: Name := 'CF_LOCALE (Win 95)'; 17: Name := 'CF_MAX (Win 95)'; $0080: Name := 'CF_OWNERDISPLAY'; $0081: Name := 'CF_DSPTEXT'; $0082: Name := 'CF_DSPBITMAP'; $0083: Name := 'CF_DSPMETAFILEPICT'; $008E: Name := 'CF_DSPENHMETAFILE'; $0200..$02FF: Name := 'private format'; $0300..$03FF: Name := 'GDI object'; Else. Name := 'unknown format'; End; MemFormats.Lines.Add(Name); End; End; End; // get rtf code from clipboard. Procedure TForm1.BtnGetRTFClick(Sender: TObject); Var. MemHandle: THandle; Begin. With Clipboard do. Begin. Open; Try. If HasFormat(CF_RTF) then. Begin. MemHandle := GetAsHandle(CF_RTF); MemExample.SetTextBuf(GlobalLock(MemHandle)); GlobalUnlock(MemHandle); End. Else. MessageDlg('The clipboard contains no RTF text!', MtError, [mbOK], 0); Finally. Close; End; End; End; // set rtf code to the clipboard. Procedure TForm1.BtnSetRTFClick(Sender: TObject); Const. Testtext: PChar = '{\rtf1\ansi\pard\plain 12{\ul 44444}}'; Testtext2: PChar = '{\rtf1\ansi' + '\deff4\deflang1033{\fonttbl{\f4\froman\fcharset0\fprq2 Times New Roman;}}' + '\pard\plain 12{\ul 44444}}'; Flap: Boolean = False; Var. MemHandle: THandle; Rtfstring: PChar; Begin. With Clipboard do. Begin. If flap then. Rtfstring := testtext2. Else. Rtfstring := testtext; Flap := not flap; MemHandle := GlobalAlloc(GHND or GMEM_SHARE, StrLen(rtfstring) + 1); If MemHandle <> 0 then. Begin. StrCopy(GlobalLock(MemHandle), rtfstring); GlobalUnlock(MemHandle); Open; Try. AsText := '1244444'; SetAsHandle(CF_RTF, MemHandle); Finally. Close; End; End. Else. MessageDlg('Global Alloc failed!', MtError, [mbOK], 0); End; End; End.

Компактный код для сортировки массива

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Компактный код для сортировки массива. Очень небольшой код для сортировки массива. Состоит из двух циклов for. Сортирует от болшего к меньшему. Зависимости: нет. Автор: Михон. Copyright: (<Михон>) (с). Дата: 14 января 2007 г. ********************************************** } For i:= 1 to 5 do begin //отвечает за место старта проверки. For j:= i to 5 do begin //сам цикл поверки. If (x[j]) > (x[i]) then begin //если следующеее число больше i,то. A:= x[j]; // X[j]:= x[i]; //меняем местами. X[i]:= a; // End; End; End;

Кнопка в MainMenu с правой стороны.

Кнопка в MainMenu с правой стороны

Code: {©Drkb v.3(2007): www.drkb.ru}. ModifyMenu(MainMenu.Handle, 3 { индекс меню, начиная слева с нуля}, Mf_ByPosition or mf_Popup or mf_Help, mnuHelp.Handle, PChar('Help'));

Автор: Smike.

Взято из http://forum.sources.ru.

©Drkb::01311.

Кнопка программы в IE.

Кнопка программы в IE.

Code: Procedure CreateExplorerButton(Path: string); {©Drkb v.3(2007): www.drkb.ru}. Const. Tagit = '\{10954C80-4F0F-11d3-B17C-00C0DFE39736}\'; Var. Reg: TRegistry; Path1: string; Merge: string; Begin. Path := 'c:\your_program_path'; Reg := TRegistry.Create; Try. With Reg do. Begin. RootKey := HKEY_LOCAL_MACHINE; Path1 := 'Software\Microsoft\Internet Explorer\Extensions'; Merge := Path1 + Tagit; OpenKey(Merge, True); WriteString('ButtonText', 'ButtonText'); WriteString('MenuText', 'Tools Menu Item'); WriteString('MenuStatusBar', 'Run Script'); WriteString('ClSid', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}'); WriteString('Default Visible', 'Yes'); WriteString('Exec', Path + '\ProgramName.exe'); WriteString('HotIcon', ',4'); WriteString('Icon', ',4'); End. Finally. Reg.CloseKey; Reg.Free; End; End;

Взято из http://forum.sources.ru.

Автор: Rouse_

©Drkb::03522.

Кнопка с закругленными краями

Code: Unit RVButton; Interface. Uses. SysUtils, Classes, Controls, Messages, Graphics, Windows; Const. IOffset = 3; Type. TRVButton = class(TGraphicControl). Private. FCaption : string; FButtonColor: TColor; FLButtonDown: boolean; FBtnPoints : array[1..2] of TPoint; FKRgn : HRgn; Procedure SetCaption(Value: string); Procedure SetButtonColor(Value: TColor); Procedure FreeRegion; Protected. Procedure Paint; override; Procedure DrawCircle; Procedure MoveButton; Procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN; Procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP; Public. Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; Published. Property ButtonColor: TColor read FButtonColor write SetButtonColor; Property Caption: string read FCaption write SetCaption; Property Enabled; Property Font; Property ParentFont; Property ParentShowHint; Property ShowHint; Property Visible; Property OnClick; End; Procedure Register; Implementation. Procedure Register; Begin. RegisterComponents('Samples', [TRVButton]); End; { TRVButton }. Constructor TRVButton.Create(AOwner: TComponent); Begin. Inherited Create(AOwner); ControlStyle := [csClickEvents,csCaptureMouse]; Width := 50; Height := 50; FButtonColor := clBtnFace; FKRgn := 0; FLButtonDown := False; End; Destructor TRVButton.Destroy; Begin. If FKRgn <> 0 then FreeRegion; Inherited Destroy; End; Procedure TRVButton.DrawCircle; Begin. FBtnPoints[1] := Point(iOffset,iOffset); FBtnPoints[2] := Point(Width - iOffset,Height - iOffset); FKRgn := CreateEllipticRgn(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y); Canvas.Brush.Color := FButtonColor; FillRgn(Canvas.Handle,FKRgn,Canvas.Brush.Handle); MoveButton; End; Procedure TRVButton.FreeRegion; Begin. If FKRgn <> 0 then DeleteObject(FKRgn); FKRgn := 0; End; Procedure TRVButton.MoveButton; Var. Color1: TColor; Color2: TColor; Begin. With Canvas do. Begin. If not FLButtonDown then. Begin. Color1 := clBtnHighlight; Color2 := clBtnShadow; End. Else. Begin. Color1 := clBtnShadow; Color2 := clBtnHighLight; End; Pen.Width := 1; If FLButtonDown then Pen.Color := clBlack. Else Pen.Color := Color2; Ellipse(FBtnPoints[1].x - 2,FBtnPoints[1].y - 2,FBtnPoints[2].x + 2,FBtnPoints[2].y + 2); If not FLButtonDown then Pen.Width := 2. Else Pen.Width := 1; Pen.Color := Color1; Arc(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y, FBtnPoints[2].x,FBtnPoints[1].y,FBtnPoints[1].x,FBtnPoints[2].y); Pen.Color := Color2; Arc(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y, FBtnPoints[1].x,FBtnPoints[2].y,FBtnPoints[2].x,FBtnPoints[1].y); End; SetCaption(''); End; Procedure TRVButton.Paint; Begin. Inherited Paint; FreeRegion; DrawCircle; End; Procedure TRVButton.SetButtonColor(Value: TColor); Begin. If Value <> FButtonColor then. Begin. FButtonColor := Value; Invalidate; End; End; Procedure TRVButton.SetCaption(Value: string); Var. X: Integer; Y: Integer; Begin. If ((Value <> FCaption) and (Value <> '')) then. Begin. FCaption := Value; End; With Canvas.Font do. Begin. Name := Font.Name; Size := Font.Size; Style := Font.Style; If Self.Enabled then Color := Font.Color. Else. Color := clDkGray; End; X := (Width div 2) - (Canvas.TextWidth(FCaption) div 2); Y := (Height div 2) - (Canvas.TextHeight(FCaption) div 2); Canvas.TextOut(X, Y, FCaption); // Invalidate; End; Procedure TRVButton.WMLButtonDown(var Message: TWMLButtonDown); Begin. If not PtInRegion(FKRgn,Message.xPos,Message.yPos) then exit; FLButtonDown := True; MoveButton; Inherited; End; Procedure TRVButton.WMLButtonUp(var Message: TWMLButtonUp); Begin. If not FLButtonDown then exit; FLButtonDown := False; MoveButton; Inherited; End; End.

Кнопка с многострочным заголовком

Code: Procedure TForm1.Button1Click(Sender: TObject); Var. I: Integer; Begin. I := GetWindowLong(Button1.Handle, GWL_STYLE); SetWindowLong(Button1.Handle, GWL_STYLE, i or BS_MULTILINE); Button1.Caption := 'Delphi World - ' + #13#10 + 'лучше не бывает!'; End;

Кнопки в панели задач

Code: // Это необходимо объявить в секции public в верхней части вашего pas-файла. Procedure TForm1.IconCallBackMessage( var Mess : TMessage ); message WM_USER + 100; Procedure TForm1.FormCreate(Sender: TObject); Var. Nid: TNotifyIconData; Begin. With nid do. Begin. CbSize := SizeOf(TNotifyIconData); Wnd := Form1.Handle; UID := 1; UFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP; UCallbackMessage := WM_USER + 100; HIcon := Application.Icon.Handle; SzTip := 'Текст всплывающей подсказки'; End; Shell_NotifyIcon(NIM_ADD, @nid); End; Procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); Var. Nid: TNotifyIconData; Begin. With nid do. Begin. CbSize := SizeOf(TNotifyIconData); Wnd := Form1.Handle; UID := 1; UFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP; UCallbackMessage := WM_USER + 100; HIcon := Application.Icon.Handle; SzTip := 'Текст всплывающей подсказки'; // Все, что указано выше, не является обязательным. End; Shell_NotifyIcon(NIM_DELETE, @nid); End; Procedure TForm1.IconCallBackMessage(var Mess: TMessage); Var. SEventLog: string; Begin. Case Mess.lParam of. // Сделайте здесь все что вы хотите. Например, // вызов контекстного меню при нажатии правой кнопки мыши. WM_LBUTTONDBLCLK: sEventLog := 'Двойной щелчок левой кнопкой'; WM_LBUTTONDOWN: sEventLog := 'Нажатие левой кнопки мыши'; WM_LBUTTONUP: sEventLog := 'Отжатие левой кнопки мыши'; WM_MBUTTONDBLCLK: sEventLog := 'Двойной щелчок мышью'; WM_MBUTTONDOWN: sEventLog := 'Нажатие кнопки мыши'; WM_MBUTTONUP: sEventLog := 'Отжатие кнопки мыши'; WM_MOUSEMOVE: sEventLog := 'перемещение мыши'; WM_MOUSEWHEEL: sEventLog := 'Вращение колесика мыши'; WM_RBUTTONDBLCLK: sEventLog := 'Двойной щелчок правой кнопкой'; WM_RBUTTONDOWN: sEventLog := 'Нажатие правой кнопки мыши'; WM_RBUTTONUP: sEventLog := 'Отжатие правой кнопки мыши'; End; End;

©Drkb::01790.

Http://delphiworld.narod.ru/

DelphiWorld 6.0.

Компонент на основе TImageList позволяет использовать в приложении анимированные иконки

Code: Unit AnimIcon; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ShellApi, TypInfo; Const. WM_FROMTRAYICON = WM_USER + 59; Type. TIconPlace = (ipAppIcon, ipAppMainFormIcon, ipFormIcon, ipImageCtrl, IpSysTray); TOnTimerEventOrder = (First, Second); TIconPlaceSet = set of TIconPlace; TTimerEvent = procedure(Sender: TObject) of object; TAnimIcon = class(TImageList). Private. { Private declarations }. FIconPlaceSet: TIconPlaceSet; FEnabled: Boolean; FInterval: Cardinal; FNumIco: Integer; FOnTimer: TTimerEvent; FImage: TImage; FAuthor: string; FTip: string; FActionForIconOnSysTray: Byte; FOnTimerEventOrder: TOnTimerEventOrder; FhWnd: hWnd; Procedure PlaceIcon; Protected. { Protected declarations }. Procedure Loaded; override; Procedure SetEnabled(Value: Boolean); Function GetEnabled: Boolean; Procedure SetInterval(Value: Cardinal); Function GetInterval: Cardinal; Procedure OnAnimIconTimer(Sender: TObject); Procedure SetImage(Value: TImage); Function GetImage: TImage; Procedure SetAuthor(Value: string); Public. { Public declarations }. Published. { Published declarations }. Constructor Create(AOwner: Tcomponent); override; //Конструктор. Destructor Destroy; override; Property IconPlace: TIconPlaceSet read FIconPlaceSet write FIconPlaceSet; Property Enabled: Boolean read GetEnabled write SetEnabled; Property Interval: Cardinal read GetInterval write SetInterval; Property OnTimer: TTimerEvent read FOnTimer write FOnTimer; Property ImageCtrl: TImage read GetImage write SetImage; Property Author: string read FAuthor write SetAuthor; Property SysTrayTip: string read FTip write FTip; Property OnTimerEventOrder: TOnTimerEventOrder read FOnTimerEventOrder write. FOnTimerEventOrder; End; Var. Timer: TTimer; Procedure Register; Function SysTrayIcon(hWindow: THandle; ID: Cardinal; ICON: hicon; CallbackMessage: Cardinal; Tip: string; Action: Byte): Boolean; Implementation. Procedure Register; Begin. RegisterComponents('MyComponents', [TAnimIcon]); End; Function SysTrayIcon(hWindow: THandle; ID: Cardinal; Icon: hicon; CallbackMessage: Cardinal; Tip: string; Action: Byte): Boolean; Var. NID: TNotifyIconData; Begin. FillChar(NID, SizeOf(TNotifyIconData), 0); With NID do. Begin. CbSize := SizeOf(TNotifyIconData); Wnd := hWindow; UID := ID; UFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP; UCallbackMessage := CallbackMessage; HIcon := Icon; If Length(Tip) > 63 then. SetLength(Tip, 63); StrPCopy(szTip, Tip); End; Case Action of. 1: Result := Shell_NotifyIcon(NIM_ADD, @NID); 2: Result := Shell_NotifyIcon(NIM_MODIFY, @NID); 3: Result := Shell_NotifyIcon(NIM_DELETE, @NID); Else. Result := False; End; End; Procedure TAnimIcon.PlaceIcon; Var. Icon: TIcon; CallbackMessage: Cardinal; Begin. Inc(FNumIco); If FNumIco > Count then. FNumIco := 1; If ipAppIcon in FIconPlaceSet then. Begin. GetIcon(FNumIco - 1, Application.Icon); Application.ProcessMessages; End; If ipFormIcon in FIconPlaceSet then. Begin. GetIcon(FNumIco - 1, TForm(Owner).Icon); Application.ProcessMessages; End; If ipAppMainFormIcon in FIconPlaceSet then. Begin. If Assigned(Application.MainForm) then. GetIcon(FNumIco - 1, Application.MainForm.Icon); Application.ProcessMessages; End; If ipImageCtrl in FIconPlaceSet then. Begin. If FImage <> nil then. GetIcon(FNumIco - 1, FImage.Picture.Icon); Application.ProcessMessages; End; If ipSysTray in FIconPlaceSet then. Begin. Icon := TIcon.Create; GetIcon(FNumIco - 1, Icon); CallbackMessage := WM_FROMTRAYICON; SysTrayIcon(FhWnd, 0, Icon.Handle, CallbackMessage, FTip, FActionForIconOnSysTray); Application.ProcessMessages; If FActionForIconOnSysTray = 1 then. FActionForIconOnSysTray := 2; End; End; Constructor TAnimIcon.Create(AOwner: TComponent); Begin. Inherited create(AOwner); FAuthor := 'V-Isa aka Inter'; FNumIco := 0; Timer := TTimer.Create(Self); Application.ProcessMessages; SetEnabled(False); SetInterval(1000); Timer.OnTimer := OnAnimIconTimer; FActionForIconOnSysTray := 0; FOnTimerEventOrder := First; If csDesigning in ComponentState then. FTip := (Owner as TForm).Caption; End; Destructor TAnimIcon.Destroy; Var. Icon: TIcon; CallbackMessage: Cardinal; Begin. If ipSysTray in FIconPlaceSet then. Begin. Icon := TIcon.Create; CallbackMessage := WM_FROMTRAYICON; SysTrayIcon(FhWnd, 0, Icon.Handle, CallbackMessage, FTip, 3); Application.ProcessMessages; End; FNumIco := 0; FEnabled := False; Timer.Enabled := FEnabled; Application.ProcessMessages; Inherited destroy; End; Procedure TAnimIcon.OnAnimIconTimer(Sender: TObject); Begin. If Assigned(FOnTimer) and (FOnTimerEventOrder = First) then. FOnTimer(Self); Application.ProcessMessages; If Count > 0 then. Begin. PlaceIcon; End; Application.ProcessMessages; If Assigned(FOnTimer) and (FOnTimerEventOrder = Second) then. FOnTimer(Self); Application.ProcessMessages; End; Procedure TAnimIcon.SetEnabled(Value: Boolean); Begin. If (Value = True) and (csDesigning in ComponentState) then. Begin. Value := False; FNumIco := 0; FEnabled := Value; Timer.Enabled := FEnabled; Application.ProcessMessages; ShowMessage('Изменение данного свойства возможно только' + #13'во время выполнения программы!!!'); Exit; End; If (Value = True) and (Count > 0) then. Begin. FActionForIconOnSysTray := 1; PlaceIcon; End; If Value = False then. Begin. FActionForIconOnSysTray := 3; PlaceIcon; End; Application.ProcessMessages; If Value = False then. FNumIco := 0; FEnabled := Value; Timer.Enabled := FEnabled; Application.ProcessMessages; End; Function TAnimIcon.GetEnabled: Boolean; Begin. GetEnabled := FEnabled; End; Procedure TAnimIcon.SetInterval(Value: Cardinal); Begin. FInterval := Value; Timer.Interval := FInterval; Application.ProcessMessages; End; Function TAnimIcon.GetInterval: Cardinal; Begin. GetInterval := FInterval; End; Procedure TAnimIcon.SetImage(Value: TImage); Begin. FImage := Value; End; Function TAnimIcon.GetImage: TImage; Begin. GetImage := FImage; End; Procedure TAnimIcon.SetAuthor(Value: string); Begin. FAuthor := 'V-Isa aka Inter'; End; Procedure TAnimIcon.Loaded; Begin. Inherited Loaded; FhWnd := (Owner as TForm).Handle; End; End.

Компонент со вложенной панелью

Автор: Ray Konopka.

Компонент TEdit с возможностью задать выравнивание текста

Code: { All you have to do is to verride the CreateParams of the class TEdit. Install the following unit as a component. } Unit AlignEdit; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TAlign = (eaLeft, eaCenter, eaRight); TAlignEdit = class(TEdit). Private. { Private-Deklarationen }. FAlign: TAlign; Procedure SetAlign(const Value: TAlign); Protected. { Protected-Deklarationen }. Procedure CreateParams(var Params: TCreateParams); override; Public. { Public-Deklarationen }. Constructor Create(AOwner: TComponent); override; Published. { Published-Deklarationen }. Property Alignment: TAlign read FAlign write SetAlign default eaLeft; End; Procedure Register; Implementation. Constructor TAlignEdit.Create(Aowner: TComponent); Begin. Inherited Create(AOwner); FAlign := eaLeft; End; Procedure TAlignEdit.SetAlign(const Value: TAlign); Begin. If FAlign <> Value then. Begin. FAlign := Value; RecreateWnd; End; End; Procedure TAlignEdit.CreateParams(var Params: TCreateParams); Begin. Inherited; Case FAlign of. EaLeft: Params.Style := Params.Style or ES_LEFT; EaCenter: Params.Style := Params.Style or ES_CENTER; EaRight: Params.Style := Params.Style or ES_RIGHT; End; End; Procedure Register; Begin. RegisterComponents('SwissDelphiCenter', [TAlignEdit]); End; End.

Компонент TNMDayTime.

Компонент TNMDayTime.

Этот компонент предназначен для получения даты и времени от серверов даты и времени в интернет и интранет в соответствии со стандартом rfc 867, называемым "Протокол времени суток". Если у вас в "подчинении" один домашний компьютер, то время на нём можно периодически подводить по своим часам - здесь точность не требуется, но если вы администратор малой или большой сети, если у вас есть многопользовательская программа, то для синхронизации времени на машинах нужно использовать некий механизм. Например, эту возможность, предоставляемую интернет. В интернете используются 4 временных протокола. Протокол, используемый в tnmdaytime, достаточно простой и даёт время с погрешностью в 1секунду. Этому протоколу требуется наличие 32-битного стека протоколов tcp/ip (библиотеки wsock32.dll), поставляемой с операционными системами windows 95/98/nt. За протоколом даты/времени закреплён порт 13. Перед тем как использовать этот компонент, вы должны знать имя или ip-адрес соответствующего сервера Интернет и присвоить это значение свойству host, в которое помещается имя сервера или разделённый точками ip-адрес. После того как вы сделали это и установили соединение, вам остаётся считать полученное значение из свойства daytimestr Пример:

Code: Procedure tform1.button1click(sender: tobject); Begin. Nmdaytime1.reportlevel:=status_basic; Nmdaytime1.timeout:=30000; Nmdaytime1.host:=edit1.text; Nmdaytime1.port:=strtoint(edit2.text); Label3.caption:=nmdaytime1.daytimestr; End;

Компонент TNMEcho.

Компонент TNMEcho.

Компонент TNMEcho.

Компонент применяется для отсылки текстовых сообщений на эхо-сервер и получения этого сообщения обратно в соответствии со стандартом rfc 862. Этот компонент обычно применяется для тестирования и настройки сети., поскольку мы можем оценить время ответа сервера, которое помещается в свойство elapsedtime. Это единственное собственное свойство компонента, остальные наследуются. Перед отправкой сообщения должно быть установлено соединение с сервером. Для этого нужно задать имя сервера или его адрес в свойстве host, а в свойстве port определить соответствующий порт [обычно серверы эхо слушают 7-ой порт]. После этого нужно вызвать метод connect. Для отправки сообщения нужно использовать метод echo. В случае успеха вы должны получить от сервера ту строку, которую вы передали в качестве параметра методу echo. После этого для завершения связи вы должны вызвать метод disconnect. Все методы, кроме echo, компонент наследует. Пример: // Подключиться nmecho1.host:=edit1.text; nmecho1.connect; // Отключиться nmecho1.disconnect; // Отправить memo1.lines.add(nmecho1.echo(edit2.text) + 'время [' + floattostr(nmecho1.elapsedtime) + ']'); // Прекратить nmecho1.abort; Источник: http://www.goldfaq.ru.

©Drkb::03391.

Компонент TNMFTP.

Компонент TNMFTP.

Компонент TNMFTP.

Компонент tnmftp предназначен для обмена файлами между сервером ftp и клиентской машиной по протоколу ftp. ftp является одной из старейших и заслуженных служб интернета. Она существовала тогда, когда ещё не было www и предоставляла удобный по тем временам сервис для обмена файлами и организации различных архивов документов и программ. Сейчас получить доступ к серверу ftp можно непосредственно из браузера www, так что клиентские программы для работы с сервером ftp уже не так актуальны. Мы рассмотрим пример с этим компонентом, поскольку такая программа может потребоваться для работы с корпоративным ftp-сервером, где доступ разграничен и требуется пройти идентификацию для доступа к файловому архиву. Перед использованием компонента tnmftp для обмена файлами с удалённым компьютером вам нужно подключиться к серверу ftp. Для этого вы должны определить свойства host и port значениями, соответствующими нужному серверу ftp. Затем задайте в свойствах userid и password необходимые имя пользователя и пароль. Многие публичные серверы ftp принимают значение anonymous в качестве имени пользователя и в качестве пароля ваш e-mail или строку, напоминающую e-mail, например, user@mycomputer.com, главное, чтобы в этой строке присутствовал символ собачки "@". Таких анонимных серверов в интернет довольно много и используются они как публичные архивы программ и документов. После определения свойств userid и password вызывайте метод connect для установки связи с сервером. Компонент tnmftp имеет следующие основные свойства: currentdir ftpdirectorylist onlistitem parselist password userid vendor Специфических методов у этого компонента немного больше: allocate changedir delete docommand download downloadrestore list makedirectory mode nlist reinitialize removedir rename upload uploadappend uploadrestore uploadunique Остальные свойства и методы этого компонента наследуются. Ниже мы разберём основные возможности этого компонента и разберём перечисленные свойства и методы. Если метод компонента tnmftp завершается успешно, то генерируется событие onsuccess, в противном случае возникает событие onfailture. В обоих случаях через параметр trans_type обработчиков этих событий передаётся имя команды типа tcmdtype. Этот параметр может принимать следующие значения: cmdchangedir cmdmakedir cmddelete cmdremovedir cmdlist cmdrename cmduprestore cmddownrestore cmddownload cmdupload cmdappend cmdreinit cmdallocate cmdnlist cmddocommand cmdcurrentdir Думаю, имя метода, к которому относится данное значение определить не трудно Определение содержимого каталога на удалённом компьютере: Если вы уже подключены к серверу, вы можете получить список файлов файлов и каталогов текущего каталога при помощи метода list и обработчика события onlistitem, которое вызывается для каждого элемента списка. Вы можете обрабатывать каждый элемент каталога в обработчике этого события. или включить режим разбора строк элементов каталога, установив свойство parselist в true. В последнем случае компонент разберёт полученные данные и поместит имена, размеры файлов атрибуты, время последнего изменения в составное свойство ftpdirectorylist. Каждый элемент этого свойства представляет собой объект типа tstringlist. Для указанных элементов списка содержимого каталога эти объекты имеют имена name[i], size[i], modifdate[i], attribute[i]. Если метод list завершается успешно, то происходит событие onsuccess, в противном случае генерируется событие onfailure. Метод nlist представляет собой сокращённый вариант команды list и используется для получения только имён файлов и каталогов. Изменение текущего каталога на удалённом компьютере: Вы можете перейти на другой каталог сервера ftp, вызывая метод changedir с именем нужного вам каталога, которое передаётся через параметр dirname. В dirname можно указывать полный путь или имя каталога относительно текущего каталога. Загрузка файлов на удалённый компьютер: Для загрузки файлов в текущий каталог на удалённом компьютере используем метод upload. Метод использует 2 параметра: имя файла на локальном компьютере и имя, под которым он будет сохраняться на удалённом [localfile, remotefile]. Нужно заметить, что для выполнения данной операции у вас должны быть соответствующие права на удалённом компьютере. Обычно серверы ftp предоставляют такие права в каталоге incoming. В том случае, если на сервере уже есть файл с тем же именем, с которым вы хотите создать новый, - этот файл будет перезаписан. Избежать этого эффекта можно, если использовать метод uploadunique. Единственный параметр localfile этого метода определяет имя файла на локальном компьютере и использует его для создаваемого файла на сервере. Если на сервере файл с таким именем уже существует, то передаваемый файл будет создан с уникальным именем. Метод uploadrestore хорош тем, что он позволяет восстановить прерванный в предыдущем сеансе процесс загрузки файла с места, в котором произошёл обрыв. Последний метод из этой серии uploadappend позволяет дописывать содержимое локального файла в конец файла на сервере, если файл существует. Если на сервере такого файла нет, то файл создаётся заново. Два последних метода имеют 2 параметра localfile и remotefile. Загрузка файлов с удалённого компьютера: Перед загрузкой файлов с удалённого компьютера имеет смысл вызвать метод list и убедиться, что нужный вам файл имеется на удалённом компьютере. После этого можно вызвать метод по имени download передав ему в качестве параметров имя загружаемого файла и имя файла и каталога на локальном компьютере: параметры remotefile и localfile. Нужно заметить, что загружать файлы из любого каталога ftp-сервера обычно не разрешается. Вы можете сделать это только из каталогов, открытых для этой операции. Если на вашем компьютере уже имеется файл с таким именем он будет перезаписан. На случай обрыва связи можно использовать метод downloadrestore, который позволит продолжить загрузку с того места, на котором произошёл обрыв связи. Создание каталога на удалённом компьютере: Для выполнения этой операции у вас должны быть соответствующие права. Обычно на ftp-серверах эти права выделяются на каталог incoming. Для создания каталога достаточно вызвать метод makedirectory, передав ему в качестве параметра имя того каталога, который вы хотите создать. Удаление файла или каталога на удалённом компьютере: Файл удаляется методом delete, а для удаления каталога применяется метод removedir. Можно задавать имя файла или каталога внутри текущего каталога или указывать полный путь и имя удаляемого объекта. Мы не упомянули ещё методы allocate, docommand, mode, reinitialize и rename. Первый метод выделяет место на ftp сервере под создаваемый файл. Как правило, этого делать не требуется, но если вам придётся работать с таким сервером, который требует выделения дисковой памяти перед закачкой на него файла, то этот метод может понадобится. Метод docommand позволяет посылать команду ftp-серверу, который должен её выполнить. Имеется в виду команда операционной системы. Этот метод может вам понадобиться, если для выполнения вашей задачи методов компонента tnmftp окажется недостаточно, либо если вам попадётся сервер с нестандартными командами. Метод rename используется для переименования файла в текущем каталоге на удалённой системе. Первый параметр filename задаёт имя файла, который нужно переименовать, второй - filename2 - новое имя для заданного файла. Метод mode задаёт режим приёма/передачи файлов. Используются 3 режима. Соответственно параметр themode может принимать соответствующие значения: mode_ascii - передача текстовых данных mode_image - двоичные данные с 8-битовыми байтами mode_byte - двоичные данные с байтами переменной длины Метод reinitialize используется для восстановления прерванного соединения. После этого метода требуется зарегистрироваться, ввести имя пользователя и пароль. Источник: sources.ru.

©Drkb::03378.

Компонет TWrapGrid, осуществляющий перенос текста в TStringGrid.

Я наконец нашел время и создал заказной компонент TWrapGrid, функционально идентичный TStringGrid, но умеющий переносить текст в ячейках. Пока это бета-версия, поэтому поэкспериментируйте с ним, и в случае наличия каких-либо замечаний или предложений не забудьте уведомить об этом меня. При использовании компонента не забывайте про RowHeights (или DefaultRowHeight), т.к. при переносе текста потребуется отобразить несколько строк.

Импорт активного документа Word.

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Импорт активного документа Word. Импортирует текст активного документа Word в объект класса TStrings (без форматирования). Если при открытом Worde результат отрицательный - рекомендуется перезапустить приложение, поскольку дальнейшие вызовы функции в подавляющем большинстве случаев будут приводить к ошибке. Зависимости: OleServer, Word97. Автор: Dimka Maslov, mainbox@endimus.com, ICQ:148442121, Санкт-Петербург. Copyright: Dimka Maslov. Дата: 6 февраля 2004 г. ********************************************** } Function ImportWordActiveDocument(Strings: TStrings): Boolean; Var. Word: TWordApplication; Start, End_: Integer; Begin. Result := True; Try. Word := TWordApplication.Create(nil); Try. Word.AutoConnect := False; Word.AutoQuit := False; Word.ConnectKind := ckRunningInstance; Word.Connect; Start := Word.Selection.Get_Start; End_ := Word.Selection.Get_End_; Word.Selection.SetRange(0, $7FFFFFFF); Strings.Text := Word.Selection.Text; Word.Selection.SetRange(Start, End_); Word.Disconnect; Finally. Word.Free; End; Except. Result := False; End; End;

Конструирование модулей.

Конструирование модулей

16. Конструирование модулей.

ВВЕДЕНИЕ.

Эта обучающая серия обещает стать возможно одной из самых долгоиграющих мини-серий в истории, конкурирующей только с задержкой на Томе IV Кнута. Начатая в 1988, эта серия вошла в четырехлетнюю паузу в 1990, когда "заботы мира сего", изменения в приоритетах и интересах и необходимость зарабатывать на жизнь казалось забросили ее после Главы 14. Долго терпевшие из вас были наконец вознаграждены весной прошлого года долгожданной Главой 15. В ней я начал попытку поставить серию обратно на рельсы и по ходу дела сделать ее проще для достижения цели, которая состоит в том, чтобы обеспечить вас не только достаточным пониманием трудных тем теории компиляции, но также достаточными инструментами в виде фиксированных подпрограмм и концепций, так чтобы вы были способны продолжать самостоятельно и стали достаточно опытными для того, чтобы создавать свои собственные синтаксические анализаторы и трансляторы. Из-за этой длинной паузы я подумал что следует вернуться назад и повторно рассмотреть концепции, которые мы до этого охватили а также заново сделать некоторые части программы. В прошлом мы никогда сильно не касались разработки программных инструментов промышленного качества... в конце концов я пытался обучать (и обучаться) концепциям, а не промышленной практике. Чтобы сделать это я старался давать вам не законченные компиляторы и анализаторы, а только те отрывки кода, которые иллюстрировали частные случаи, которые мы рассматривали в текущий момент.

Я все еще верю, что это хороший способ изучения любого вопроса; никто не захочет вносить в изменения в программу в 100,000 строк только для того чтобы попробовать новую идею. Но идея работы с обрывками кода а не полными программами также имеет свои недостатки из-за которых мы писали те же самые фрагменты кода много раз. Хотя было полностью доказано, что повторение является хорошим способом обучения новым идеям, также правда и то, что оно может быть не слишком хорошей вещью. Ко времени, когда я завершил Главу 14, я казалось достиг пределов своих способностей манипулировать множеством файлов и множественными версиями тех же самых программ. Кто знает, может быть это одна из причин, по которым я кажется выдохся в то время.

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

Так как к настоящему времени большинство из вас программируют на C или C++, я знаю, что вы подумаете: Borland с их Turbo Pascal конечно не изобретали понятие раздельно компилируемых модулей. И, конечно, вы правы. Но если вы не использовали TP в последнее время или когда либо, вы можете не понять насколько безболезненный весь этот процесс. Даже в C или C++ вы все еще должны формировать make файл, или вручную, или сообщая компилятору как это сделать. Вы должны также перечислить, используя утверждение "extern" или заголовочные файлы, функции, которые вы хотите импортировать. В TP вы не должны даже делать этого. Вам необходимы только имена модулей, которые вы желаете использовать, и все их процедуры автоматически становятся доступны.

У меня нет намерения заниматься здесь дебатами на тему войн языков, так что я не буду затрагивать эту тему в дальнейшем. Даже я больше не использую Pascal в своей работе... я использую C на работе и С++ для своих статей в Embedded Systems Programming и других журналах. Поверьте мне, когда я намеревался возродить эту серию, я думал долго и интенсивно о переключении и языка и целевой системы на те, которые мы все используем в эти дни, C/C++ и архитектуру PC и возможно также и объектно-ориентированные методы. В конце концов я понял, что это вызовет больше беспорядка, чем сам перерыв. И в конце концов, Pascal все еще остается одним из лучших возможных языков для обучения, не говоря о промышленном программировании. Наконец, TP все еще компилирует на скорости света, гораздо быстрее чем конкурирующие C/C++ компиляторы. А интеллектуальный компоновщик Borland, использованный в TP но не в их продуктах C++ не имеет аналогов. Кроме того, что он намного быстрее, чем Microsoft-совместимые компоновщики, Borland-овский интеллектуальный компоновщик отберет неиспользуемые процедуры и элементы данных даже вплоть до вырезания их из определенных объектов если они не нужны. Один из редких моментов нашей жизни, когда мы не должны идти на компромисс между полнотой и эффективностью. Когда мы пишем модуль TP мы можем сделать его настолько полным как нам нравится, включая любые функции и элементы данных которые, как мы думаем, могут нам когда-либо понадобиться, уверенные, что это не будет создавать ненужного раздутия кода в откомпилированной выполнимой программе.

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

Используя этот принцип, в Главе 15 я намеревался минимизировать нашу тенденцию заново изобретать колесо, организуя наш код в отдельные модули Turbo Pascal, каждый из которых содержит различные части компилятора. Мы завершили со следующими модулями:

· Input

· Output

· Errors

· Scanner

· Parser

· CodeGen

Каждый из этих модулей обслуживает разные функции и изолирует специфические области функциональных возможностей. Модули Input и Output, как подразумевают их имена, обеспечивают ввод/вывод символьного потока и важнейший предсказывающий символ, на котором основан наш предсказывающий синтаксический анализатор. Модуль Errors конечно обеспечивает стандартную обработку ошибок. Модуль Scanner содержит все наши булевы функции типа IsAlpha и подпрограммы GetName и GetNumber, которые обрабатывают много символьные токены.

Два модуля, с которыми мы будем в основном работать и те, которые больше всего представляют индивидуальность нашего компилятора - это Parser и CodeGen. Теоретически модуль Parser должен изолировать все аспекты компилятора, которые зависят от синтаксиса компилируемого языка (хотя, как мы видели последний раз, небольшое количество этого синтаксиса перетекает в Scanner). Аналогично, модуль генератора кода, CodeGen, содержит весь код, зависящий от целевой машины. В этой главе мы продолжим разработку функций в этих двух важнейших модулях.

СОВСЕМ КАК КЛАССИЧЕСКИЙ?

Прежде чем мы продолжим, однако, я думаю что должен разъяснить связи между модулями и функциональные возможности этих модулей. Те из вас, кто знаком с теорией компиляции как обучавшиеся в университетах, конечно распознают имена Scanner, Parser и CodeGen, все из которых являются компонентами классической реализации компилятора. Вы можете думать, что я отказался от своих обязательств по отношению к философии KISS и отдрейфовал к более стандартной архитектуре чем мы имели. Более пристальный взгляд, однако, должен убедить вас, что хотя имена схожи, функциональность совершенно различна.

Вместе, сканер и парсер классической реализации составляют так называемый "front end", а генератор кода "back end". Подпрограммы "front end" обрабатывают языко зависимые, связанные с синтаксисом аспекты исходного языка, в то время как генератор кода, или "back end", работает с зависимыми от целевой машины частями проблемы. В классических компиляторах два конца (ends) сообщаются через файл инструкций, написанный на промежуточном языке (IL).

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

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

Аналогично, классический генератор кода, "back end", в своем роде тоже транслятор, считывающий "исходный" IL файл и выдающий объектный файл. Наш генератор кода не работает таким способом. В нашем компиляторе нет никакого промежуточного языка; каждая конструкция в синтаксисе исходного языка преобразуется в ассемблер как только она распознана синтаксическим анализатором. Подобно Scanner, модуль CodeGen состоит из индивидуальных процедур, которые вызываются синтаксическим анализатором когда необходимо.

Философия "кодируй как только найдешь" не может производить самый эффективный код в мире - например, мы не обеспечили (пока!) удобное место для оптимизатора - но она несомненно упрощает компилятор, не правда ли?

И этот наблюдение заставляет меня повторить снова то, как нам удавалось сводить функции компилятора к таким сравнительно простым условиям. Я набрался красноречивости на эту тему в прошлых главах, поэтому здесь я не буду слишком ее трогать. Однако, из-за времени, прошедшего с этих последних монологов, я надеюсь что вы предоставите мне совсем немного времени напомнить себе, так же как и вам, как мы попали сюда. Мы дошли до этого применяя несколько принципов, которые создатели коммерческих компилятором редко имеют роскошь использовать. Вот они:

· Философия KISS - никогда не делай сложные вещи без причины.

· Ленивое кодирование - Никогда не откладывай на завтра то, что можешь отложить навсегда. (П. Дж. Плоджер).

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

· Принятие неэффективного кода.

· Отклонение произвольных ограничений.

Когда я сделал обзор истории конструирования компиляторов, я узнал, что практически каждый промышленный компилятор в истории страдал из-за предналоженных условий, которые сильно влияли на его дизайн. Первоначальный компилятор Fortran Джона Бэкуса должен был конкурировать с ассемблером и следовательно был вынужден производить чрезвычайно эффективный код. Компиляторы IBM для мини ЭВМ 70-х должны были выполняться в очень небольших объемах ОЗУ тогда доступных - таких небольших как 4k. Ранние компиляторы Ada должны были компилировать себя. Бринч Хансен решил, что его компилятор Паскаля, разработанный для IBM PC должен выполняться на 64k машинах. Компиляторы, разработанные на курсах Computer Science, должны были компилировать широкий диапазон языков и следовательно требовали LALR синтаксических анализаторов.

В каждом из этих случаев эти предвзятые ограничения буквально доминировали над проектом компилятора.

Хороший пример - компилятор Бринч Хансена, описанный в его превосходной книге "Brinch Hansen on Pascal Compilers" (строго рекомендую). Хотя его компилятор один из самых ясных и незатемненных реализаций компилятора, что я видел, одно решение, компилировать большие файлы в небольшом ОЗУ, полностью управляло дизайном и он закончил не на одном а многих промежуточных файлах, как и управляющими ими программах для их записи и считывания.

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

В этой обучающей серии мы следовали по шагам таких пионеров в мире маленьких компиляторов для PC как Леор Золман, Рон Каин и Джеймс Хендрих, тех кто не знал достаточно теорию компиляции чтобы знать, что они "не могли делать это таким способом". Мы решительно отказались принимать произвольные ограничения, а скорее делали так, как было проще В результате мы развили архитектуру, которая, хотя и совершенно отлична от классической, делает работу простым и прямым способом.

Я закончу эти философствования обзором понятия промежуточного языка. Хотя я отметил перед этим, что мы не имеем его в нашем компиляторе, это не совсем точно; у нас он есть, или по крайней мере мы развиваем его, в том смысле, что мы определяем функции генерации кода для вызова из парсера. В сущности, каждый вызов процедуры генерации кода можно рассматривать как инструкцию на промежуточном языке. Если мы когда либо найдем необходимым формализировать промежуточный язык, вот способ, которым бы мы сделали это: выдать кода из синтаксического анализатора, представляющие собой вызовы процедур генератора кода, а затем обработать каждый код вызывая эти процедуры в отдельном проходе, реализованном в "back end". Откровенно говоря, я не вижу, что мы когда либо найдем потребность в таком подходе, но это связь, если вы решите следовать ему, между классическим и текущим подходами.

РАСШИРЕНИЕ СИНТАКСИЧЕСКОГО АНАЛИЗАТОРА.

Хотя я обещал вам где-то в Главе 14, что мы никогда снова не будем переписывать каждую одиночную функцию заново, я начал делать это с Главы 15. Единственная причина: эта длинная пауз между двумя главами делала обзор кажущимся чрезвычайно оправданным... даже необходимым и для вас и для меня. Более важно, решение собрать процедуры в модули заставило нас взглянуть на каждую из них снова, хотели мы этого или нет. И, наконец, откровенно говоря, за последние четыре года у меня появились некоторые новые идеи, которые гарантировали свежий взгляд на некоторые старые вещи. Когда я с начала начал эту серию я был искренне поражен и обрадован, узнав насколько простыми могут быть сделаны подпрограммы анализа. Но в этот последний раз я удивил сам себя снова и был способен делать их точно также, но даже немного проще.

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

Сначала, давайте позаботимся о проблеме, к которой мы обращались прежде: наша текущая версия процедуры Factor, как мы оставили ее в Главе 15, не может обрабатывать отрицательные параметры. Чтобы исправить это мы представим процедуру SignedFactor:

Code: { Parse and Translate a Factor with Optional Sign }. Procedure SignedFactor; Var Sign: char; Begin. Sign := Look; If IsAddop(Look) then. GetChar; Factor; If Sign = '-' then Negate; End;

Заметьте, что эта процедура вызывает новую подпрограмму генерации кода Negate:

Code: { Negate Primary }. Procedure Negate; Begin. EmitLn('NEG D0'); End;

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

В основной программе просто измените вызов процедуры Factor на SignedFactor и протестируйте код. Разве не хорошо компоновщик Turbo и средство make поддерживают все детали?

Да, я знаю, код не очень эффективен. Если мы введем число -3 будет сгенерирован такой код:

MOVE #3,D0.

NEG D0.

Что действительно, действительно грубо. Мы можем сделать лучше, конечно, просто предварительно добавив знак минус к строке, передаваемой в LoadConstant, но это добавляет несколько строк кода в SignedFactor и здесь я применяю философию KISS очень агрессивно. Более того, сказать правду, я думаю что подсознательно наслаждаюсь генерацией "действительно грубого" кода, так как я могу иметь удовольствие наблюдать как он будет становиться драматически лучше, когда мы примемся за методы оптимизации.

Большинство из вас никогда не слышало о Джоне Спрее, поэтому позвольте мне представить его вам здесь. Джон из Новой Зеландии и преподает информатику в одном из ее университетов. Джон написал компилятор для Motorola 6809, основанный на восхитительном, Паскаль подобном языке собственной разработки, названном "Whimsical". Позднее он перенес компилятор на 68000 и некоторое время это был единственный компилятор, который я имел для своей доморощенной системы на 68000.

К слову сказать, один из моих стандартных тестов для любого компилятора - изучение того, как компилятор работает с пустой программой типа:

Program main;

Begin.

End.

Мой тест измеряет время, требуемое на компиляцию и связывание, и размер сгенерированного объектного файла. Бесспорный проигравший в этом тесте - компилятор DEC C для VAX, который тратит 60 секунд на компиляцию на VAX 11/780 и генерирует объектный файл 50k. Компилятор Джона бесспорно сейчас, в будущем и навсегда король по части размера кода. Для данной пустой программе Whimsical генерирует точно два байта, реализуя одну инструкцию:

RET.

Устанавливая опцию компилятора генерировать include файл а не автономную программу, Джон может даже урезать этот размер с двух байт до нуля! Несколько трудно добиться нулевого объектного файла, вы не согласны?

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

ТЕРМЫ И ВЫРАЖЕНИЯ.

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

Выражение.

Терм.

Показатель.

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

Code: { Parse and Translate an Expression }. Procedure Expression; Begin. SignedFactor; While IsAddop(Look) do. Case Look of. '+': Add; '-': Subtract; End; End;

Эта процедура вызывает две другие процедуры для обработки операций:

Code: { Parse and Translate an Addition Operation }. Procedure Add; Begin. Match('+'); Push; Factor; PopAdd; End; { Parse and Translate a Subtraction Operation }. Procedure Subtract; Begin. Match('-'); Push; Factor; PopSub; End;

Эти три процедуры Push, PopAdd и PopSub - новые подпрограммы генерации кода. Как подразумевает имя, процедура Push генерирует код для помещения основного регистра (D0 в нашей реализации для 68000) в стек. PopAdd и PopSub выталкивают вершину стека и прибавляют или вычитают ее из основного регистра. Код показан ниже:

Code: { Push Primary to Stack }. Procedure Push; Begin. EmitLn('MOVE D0,-(SP)'); End; { Add TOS to Primary }. Procedure PopAdd; Begin. EmitLn('ADD (SP)+,D0'); End; { Subtract TOS from Primary }. Procedure PopSub; Begin. EmitLn('SUB (SP)+,D0'); Negate; End;

Добавьте эти подпрограммы в Parser и CodeGen и измените основную программу для вызова Expression. Вуа ля!

Следующий шаг, конечно, это добавление возможности работы с мульпликативными термами. С этой целью мы добавим процедуру Term и процедуры генерации кода PopMul и PopDiv. Эти процедуры генерации кода показаны ниже:

Code: { Multiply TOS by Primary }. Procedure PopMul; Begin. EmitLn('MULS (SP)+,D0'); End; { Divide Primary by TOS }. Procedure PopDiv; Begin. EmitLn('MOVE (SP)+,D7'); EmitLn('EXT.L D7'); EmitLn('DIVS D0,D7'); EmitLn('MOVE D7,D0'); End;

Я должен признать, что подпрограмма деления немного перегружена, но с этим ничего нельзя поделать. К сожалению, хотя процессор 68000 позволяет выполнять деление используя вершину стека (TOS), он требует аргументы в неправильном порядке, подобно тому как для вычитания. Поэтому наше единственное спасение в том чтобы вытолкнуть стек в рабочий регистр (D7), выполнить там деление, и затем поместить результат обратно в наш основной регистр D0. Обратите внимание на использование знаковых операций умножения и деления. Этим неявно подразумевается что все наши переменные будут 16-разрядными целыми числами со знаком. Это решение затронет нас позднее, когда мы начнем рассматривать множественные типы данных, преобразования типов и т.п.

Наша процедура Term это практически аналог Expression и выглядит так:

Code: { Parse and Translate a Term }. Procedure Term; Begin. Factor; While IsMulop(Look) do. Case Look of. '*': Multiply; '/': Divide; End; End;

Наш следующий шаг - изменение некоторых имен. SignedFactor теперь становится SignedTerm а вызовы Factor в Expression, Add, Subtract и SignedTerm заменяются на вызов Term:

Code: { Parse and Translate a Term with Optional Leading Sign }. Procedure SignedTerm; Var Sign: char; Begin. Sign := Look; If IsAddop(Look) then. GetChar; Term; If Sign = '-' then Negate; End; ... { Parse and Translate an Expression }. Procedure Expression; Begin. SignedTerm; While IsAddop(Look) do. Case Look of. '+': Add; '-': Subtract; End; End;

Если память мне не изменяет мы однажды уже имели и процедуру SignedFactor и SignedTerm. У меня были причины сделать так в то время... они имели отношение к обработке булевой алгебры и, в частности, булевой функции "not". Но, конечно, для арифметических операций дублирование не нужно. В выражении типа:

-x*y.

Очевидно, что знак идет со всем термом x*y а не просто с показателем x и таким способом Expression и закодирован.

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

Наше последнее дело, относительно выражений, это модификация процедуры Factor для разрешения выражений в скобках. Используя рекурсивный вызов Expression мы можем уменьшить необходимый код практически до нуля. Пять строк, добавленные в Factor, выполнят эту работу:

Code: { Parse and Translate a Factor }. Procedure Factor; Begin. If Look ='(' then begin. Match('('); Expression; Match(')'); End. Else if IsDigit(Look) then. LoadConstant(GetNumber). Else if IsAlpha(Look)then. LoadVariable(GetName). Else. Error('Unrecognized character ' + Look); End;

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

ПРИСВАИВАНИЯ.

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

Code: { Parse and Translate an Assignment Statement }. Procedure Assignment; Var Name: string; Begin. Name := GetName; Match('='); Expression; StoreVariable(Name); End;

Присваивание вызывает еще одну подпрограмму генерации кода:

Code: { Store the Primary Register to a Variable }. Procedure StoreVariable(Name: string); Begin. EmitLn('LEA ' + Name + '(PC),A0'); EmitLn('MOVE D0,(A0)'); End;

Теперь измените вызов в Main на вызов Assignment и вы должны увидеть полную операцию присваивания, обрабатываемую правильно. Довольно хорошо, не правда ли? И безболезненно также.

В прошлом мы всегда старались показывать БНФ уравнения для определения синтаксиса, который мы разрабатываем. Я не сделал этого здесь и давно пора это сделать. Вот эти БНФ:

<factor> ::= <variable> | <constant> | '(' <expression> ')'

<signed_term> ::= [<addop>] <term> <term> ::= <factor> (<mulop> <factor>)* <expression> ::= <signed_term> (<addop> <term>)*

<assignment> ::= <variable> '=' <expression>

БУЛЕВА АЛГЕБРА.

Следующий шаг, как мы изучили несколько раз до этого, это добавление булевой алгебры. В прошлом этот шаг по крайней мере удваивал количество кода, который мы должны были написать. Когда я прошел эти шаги в своем уме, я обнаружил, что отклоняюсь все больше и больше от того, что мы делали в предыдущих главах. Чтобы освежить вашу память, я отметил, что Паскаль обрабатывает булевы операторы в значительной степени идентично способу, которым он обрабатывает арифметические операторы. Булево "and" имеет тот же самый уровень приоритета, что и умножение, а "or" то же что сложение. Си, с другой стороны, устанавливает их на различных уровнях приоритета, которые занимают 17 уровней. В нашей более ранней работе я выбрал что-то среднее, с семью уровнями. В результате, мы закончили на чем-то называющемся булевыми выражениями, соответствующим в большинстве деталей арифметическим выражениям, но на другом уровне приоритета. Все это, как оказалось, возникло потому, что мне не хотелось помещать скобки вокруг булевых выражений в утверждениях типа:

IF (c >= 'A') and (c <= 'Z') then ...

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

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

С начала, мы добавим в Expression операторы "уровня сложения". Это легко сделать; во-первых, измените функцию IsAddop в модуле Scanner чтобы включить два дополнительных оператора: '|' для "или" и "~" для "исключающее или":

Function IsAddop(c: char): boolean; begin IsAddop := c in ['+','-', '|', '~']; end;

Затем, мы должны включить анализ операторов в процедуру Expression:

Code: Procedure Expression; Begin. SignedTerm; While IsAddop(Look) do. Case Look of. '+': Add; '-': Subtract; '|': _Or; '~': _Xor; End; End;

(Символы подчеркивания необходимы, конечно, потому что "or" and "xor" являются зарезервированными словами Turbo Pascal).

Затем процедуры _Or and _Xor:

Code: { Parse and Translate a Subtraction Operation }. Procedure _Or; Begin. Match('|'); Push; Term; PopOr; End; { Parse and Translate a Subtraction Operation }. Procedure _Xor; Begin. Match('~'); Push; Term; PopXor; End;

И, наконец, новые процедуры генерации кода:

Code: { Or TOS with Primary }. Procedure PopOr; Begin. EmitLn('OR (SP)+,D0'); End; { Exclusive-Or TOS with Primary }. Procedure PopXor; Begin. EmitLn('EOR (SP)+,D0'); End;

Теперь давайте протестируем транслятор (вы возможно захотите изменить вызов в Main обратно на вызов Expression просто чтобы избежать необходимости набирать каждый раз "x=" для присваивания).

Пока все хорошо. Синтаксический анализатор четко обрабатывает выражения вида:

X|y~z.

К сожалению, он также не делает ничего для того, чтобы защитить нас от смешивания булевой и арифметической алгебры. Он радостно сгенерирует код для:

(a+b)*(c~d).

Мы говорили об этом немного в прошлом. Вообще, правила какие операции допустимы а какие нет не могут быть применены самим синтаксическим анализатором, потому что они не являются частью синтаксиса языка, а скорее его семантики. Компилятор, который не разрешает смешанные выражения такого вида должен распознать, что c и d являются булевыми переменными а не числовыми и передумать об их умножении на следующем шаге. Но такая "охрана" не может быть выполнена синтаксическим анализатором; она должна быть обработана где-то между синтаксическим анализатором и генератором кода. Мы пока не в таком положении, чтобы устанавливать такие правила, потом что у нас нет способа ни объявления типов, ни таблицы идентификаторов для сохранения в ней типов. Так что, для того что у нас на данный момент работает, синтаксический анализатор делает точно то, что он предназначен делать.

В любом случае, уверены ли мы, что не хотим разрешить операции над смешанными типами? Некоторое время назад мы приняли решение (или по крайней мере я принял) чтобы принимать значение 0000 как логическую "ложь" и -1 или FFFFh как логическую "истину". Хорошо в этом выборе то, что побитовые операции работают точно таким же способом, что и логические. Другими словами, когда мы выполняем операцию с одним битом логической переменной, мы делаем это над всеми из них. Это означает, что мы не должны делать различия между логическими и поразрядными операциями, как это сделано в C операторами & и &&, и | и ||. Уменьшение числа операторов наполовину конечно не выглядит совсем плохим.

С точки зрения данных в памяти, конечно, компьютер и компилятор не слишком интересуются, представляет ли число FFFFh логическую истину или число -1. Должны ли мы? Я думаю что нет. Я могу придумать множество примеров (хотя они могут быть рассмотрены как "мудреный" код) где возможность смешивать типы могла бы пригодиться. Пример, функция дельты Дирака, которая могла бы быть закодирована в одной простой строке:

-(x=0).

Или функция абсолютного значения (определенно сложный код!):

X*(1+2*(x<0)).

Пожалуйста, заметьте, что я не защищаю программирование подобным образом как стиль жизни. Я почти обязательно написал бы эти функции в более читаемой форме, используя IF, только для того, чтобы защитить от запутывания того, кто будет сопровождать программу в будущем. Все же возникает моральный вопрос: Имеем ли мы право осуществлять наши идеи о хорошей практике кодирования на программисте, написав язык так, чтобы он не смог сделать что-нибудь не так? Это то, что сделал Никлаус Вирт во многих местах Паскаля и Паскаль критиковался за это - как не такой "прощающий" как Си.

Интересная параллель представлена в примере дизайна Motorola 68000. Хотя Motorola громко хвастается об ортогональности их набора инструкций, факт то, что он является далеко не ортогональным. К примеру, вы можете считать переменную по ее адресу:

MOVE X,D0 (где X это имя переменной).

Но вы не можете записать ее таким же образом. Для записи вы должны загрузить в регистр адреса адрес X. То же самое остается истиной и для PC-относительной адресации.

MOVE X(PC),DO (допустимо).

MOVE D0,X(PC) (недопустимо).

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

Один из уроков, которым я научился в жизни: Если у вас есть два выбора и вы не можете решить которому их них последовать, иногда самое лучшее - не делать ничего. Зачем добавлять дополнительные ограничители в процессор, чтобы осуществить чужие представления о хорошей практике программирования? Оставьте эти инструкции и позвольте программистам поспорить что такое хорошая практика программирования. Точно так же, почему мы должны добавлять дополнительный код в наш синтаксический анализатор для проверки и предупреждения условий, которые пользователь мог бы предпочесть использовать? Я предпочел бы оставить компилятор простым и позволить программным экспертам спорить, должна ли такая практика использоваться или нет.

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

БУЛЕВО "AND".

С это небольшой философией, мы можем приступить к оператору "and", который пойдет в процедуру Term. К настоящему времени вы возможно сможете сделать это без меня, но в любом случае вот код:

В Scanner:

Code: Function IsMulop(c: char): boolean; Begin. IsMulop := c in ['*','/', '&']; End; В Parser: Procedure Term; Begin. Factor; While IsMulop(Look) do. Case Look of. '*': Multiply; '/': Divide; '&': _And; End; End; { Parse and Translate a Boolean And Operation }. Procedure _And; Begin. Match('&'); Push; Factor; PopAnd; End; И в CodeGen: { And Primary with TOS }. Procedure PopAnd; Begin. EmitLn('AND (SP)+,D0'); End;

Ваш синтаксический анализатор теперь должен быть способен обрабатывать почти любые виды логических выражений а также (если вы хотите) и смешанные выражения.

Почему не "все виды логических выражений"? Потому что пока мы не имели дела с логическим оператором "not" и с ним все становится сложнее. Логический оператор "not" кажется на первый взгляд идентичным в своем поведении унарному минусу, поэтому моей первой мыслью было позволить оператору исключающего или, '~', дублировать унарный "not". Это не работало. При моей первой попытке процедура SignedTerm просто съедала мой '~' потому что символ проходил проверку на addop но SignedTerm игнорировал все addop за исключением "-". Было бы достаточно просто добавить другую строку в SignedTerm, но это все равно не решит проблему, потому что, заметьте, Expression принимает терм со знаком только для первого аргумента.

Математически, выражение типа:

-a * -b.

Имеет небольшой или совсем никакого смысла и синтаксический анализатор должен отметить его как ошибку. Но то же самое выражение, использующее логическое "not", имеет точный смысл:

Not a and not b.

В случае с этими унарными операторами выбор заставить их работать таким же самым способом кажется искусственным принуждением, жертвованием приемлемым поведением на алтаре простоты реализуемости. Хотя я полностью за сохранение реализации настолько простой, насколько возможно, я не думаю, что мы должны делать это за счет приемлемости. Исправления подобные этому, приведут к потере основной детали, которая заключается в том, чтобы логическое "not" просто не является тем же самым что унарный минус. Рассмотрим исключающее "or", которое обычно записывается так:

A~b ::= (a and not b) or (not a and b).

Если мы разрешим "not" изменять весь терм, последний терм в круглых скобках интерпретировался бы как:

Not(a and b).

Что совсем не то же самое. Так что ясно, что о логическом "not" нужно думать как о связанном с показателем а не термом.

Идея перегрузки оператор '~' не имеет смысла и с математической точки зрения. Применение унарного минуса эквивалентно вычитанию из нуля:

-x <=> 0-x.

Фактически, в одной из моих более простых версий Expression я реагировал на ведущий addop просто предзагружая нуль, затем обрабатывая оператор как если бы это был двоичный оператор. Но "not" это не эквивалент исключающему или с нулем... которое просто возвратит исходное число. Вместо этого, это исключающее или с FFFFh или -1.

Короче говоря, кажущаяся близость между унарным "not" и унарным минусом разваливается при более близком исследовании. "not" изменяет показатель а не терм и он не имеет отношения ни к унарному минусу, ни исключающему или. Следовательно, он заслуживает своего собственного символа для вызова. Какой символ лучше, чем очевидный, также используемый в Си символ "!"? Используя правила того как мы думаем должен вести себя "not", мы должны быть способны закодировать исключающее или (предполагая что это нам когда-нибудь понадобится) в очень естественной форме:

A & !b | !a & b.

Обратите внимание, что никаких круглых скобок не требуется - выбранные нам уровни приоритета автоматически заботятся обо всем.

Если вы продолжаете учитывать уровни приоритета, это определение помещает '!' на вершину кучи. Уровни становятся:

1. !

2. (унарный)

3. *, /, &

4. +, -, |, ~

Рассматривая этот список, конечно не трудно увидеть, почему мы имели проблему при использовании '~' как символа "not"!

Так, как мы механизируем эти правила? Таким же самым способом, как мы сделали с SignedTerm, но на уровне показателя. Мы определим процедуру NotFactor:

Code: { Parse and Translate a Factor with Optional "Not" }. Procedure NotFactor; Begin. If Look ='!' then begin. Match('!'); Factor; Notit; End. Else. Factor; End;

И вызовем ее из всех мест, где мы прежде вызывали Factor, т.е. из Term, Multiply, Divide и _And. Обратите внимание на новую процедуру генерации кода:

{ Bitwise Not Primary }.

Procedure NotIt; begin EmitLn('EOR #-1,D0'); end;

Испытайте ее сейчас с несколькими простыми случаями. Фактически, попробуйте пример с исключающим или:

A&!b|!a&b.

Вы должны получить код (без комментариев, конечно):

Code: MOVE A(PC),DO ; load a. MOVE D0,-(SP) ; push it. MOVE B(PC),DO ; load b. EOR #-1,D0 ; not it. AND (SP)+,D0 ; and with a. MOVE D0,-(SP) ; push result. MOVE A(PC),DO ; load a. EOR #-1,D0 ; not it. MOVE D0,-(SP) ; push it. MOVE B(PC),DO ; load b. AND (SP)+,D0 ; and with !a. OR (SP)+,D0 ; or with first term.

Это точно то, что мы хотели получить. Так что, по крайней мере, и для арифметических и для логических операторов наш новый приоритет и новый, более тонкий синтаксис, поддерживают друг друга. Даже специфическое, но допустимое выражение с ведущим addop:

~x.

Имеет смысл. SignedTerm игнорирует ведущий '~' как и должно быть, так как выражение эквивалентно:

0~x,

Что эквивалентно x.

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

<not_factor> ::= [!] <factor>

<factor> ::= <variable> | <constant> | '(' <expression> ')' <signed_term> ::= [<addop>] <term> <term> ::= <not_factor> (<mulop> <not_factor>)* <expression> ::= <signed_term> (<addop> <term>)*

<assignment> ::= <variable> '=' <expression>

Это большое улучшение предыдущих достижений. Будет ли сохраняться наша удача когда мы примемся за операторы отношений? Мы выясним это скоро, но мы должны будем дождаться следующей главы. У нас выдалась подходящая пауза и я хочу выдать эту главу в ваши руки. Уже прошел год с выпуска Главы 15. Я боюсь признаться, что вся эта текущая глава была готова уже давно, за исключением операторов отношений. Но эта информация совсем не дает вам ничего хорошего, сидя на моем жестком диске, и удерживая ее пока операторы отношений не будут сделаны, я не давал ее в ваши руки все это время. Пришло время выдать ее чтобы вы смогли получить из нее что-нибудь ценное. Кроме того, имеется большое количество серьезных философских вопросов, связанных с операторами отношений, и я предпочел бы сохранить их для отдельной главы, где я смог бы сделать это корректно.

Развлекайтесь с новой более тонкой арифметикой и логическим анализом.

Как показать контекстное меню для конкретного файла?

Как показать контекстное меню для конкретного файла?

Code: //////////////////////////////////////////////////////////////////////////////// // // **************************************************************************** // * Unit Name : Unit1. // * Purpose : Демо отображения системного контекстного меню эксплорера. // * Author : Александр (Rouse_) Багель. // * Version : 1.00. // **************************************************************************** // Unit Unit1; Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, // Чтоб все заработало - подключаем вот эти 2 юнита. ShlObj, ActiveX; Type. TForm1 = class(TForm). Button1: TButton; Procedure Button1Click(Sender: TObject); End; Var. Form1: TForm1; Implementation. {$R *.dfm}. // Это для работы самого меню, как оконного элемента. Function MenuCallback(Wnd: HWND; Msg: UINT; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall; Var. ContextMenu2: IContextMenu2; Begin. Case Msg of. WM_CREATE: Begin. ContextMenu2 := IContextMenu2(PCreateStruct(lParam).lpCreateParams); SetWindowLong(Wnd, GWL_USERDATA, Longint(ContextMenu2)); Result := DefWindowProc(Wnd, Msg, wParam, lParam); End; WM_INITMENUPOPUP: Begin. ContextMenu2 := IContextMenu2(GetWindowLong(Wnd, GWL_USERDATA)); ContextMenu2.HandleMenuMsg(Msg, wParam, lParam); Result := 0; End; WM_DRAWITEM, WM_MEASUREITEM: Begin. ContextMenu2 := IContextMenu2(GetWindowLong(Wnd, GWL_USERDATA)); ContextMenu2.HandleMenuMsg(Msg, wParam, lParam); Result := 1; End; Else. Result := DefWindowProc(Wnd, Msg, wParam, lParam); End; End; // Это для создания самого меню, как оконного элемента. Function CreateMenuCallbackWnd(const ContextMenu: IContextMenu2): HWND; Const. IcmCallbackWnd = 'ICMCALLBACKWND'; Var. WndClass: TWndClass; Begin. FillChar(WndClass, SizeOf(WndClass), #0); WndClass.lpszClassName := PChar(IcmCallbackWnd); WndClass.lpfnWndProc := @MenuCallback; WndClass.hInstance := HInstance; Windows.RegisterClass(WndClass); Result := CreateWindow(IcmCallbackWnd, IcmCallbackWnd, WS_POPUPWINDOW, 0, 0, 0, 0, 0, 0, HInstance, Pointer(ContextMenu)); End; Procedure GetProperties(Path: String; MousePoint: TPoint; WC: TWinControl); Var. CoInit, AResult: HRESULT; CommonDir, FileName: String; Desktop, ShellFolder: IShellFolder; PchEaten, Attr: Cardinal; PathPIDL: PItemIDList; FilePIDL: array [0..1] of PItemIDList; ShellContextMenu: HMenu; ICMenu: IContextMenu; ICMenu2: IContextMenu2; PopupMenuResult: BOOL; CMD: TCMInvokeCommandInfo; M: IMAlloc; ICmd: Integer; CallbackWindow: HWND; Begin. // Первичная инициализация. ShellContextMenu := 0; Attr := 0; PathPIDL := nil; CallbackWindow := 0; CoInit := CoInitializeEx(nil, COINIT_MULTITHREADED); Try. // Получаем пути и имя фала. CommonDir := ExtractFilePath(Path); FileName := ExtractFileName(Path); // Получаем указатель на интерфейс рабочего стола. If SHGetDesktopFolder(Desktop) <> S_OK then. RaiseLastOSError; // Если работаем с папкой. If FileName = '' then. Begin. // Получаем указатель на папку "Мой компьютер". If (SHGetSpecialFolderLocation(0, CSIDL_DRIVES, PathPIDL) <> S_OK) or. (Desktop.BindToObject(PathPIDL, nil, IID_IShellFolder, Pointer(ShellFolder)) <> S_OK) then RaiseLastOSError; // Получаем указатель на директорию. ShellFolder.ParseDisplayName(WC.Handle, nil, StringToOleStr(CommonDir), PchEaten, FilePIDL[0], Attr); // Получаем указатель на контектсное меню папки. AResult := ShellFolder.GetUIObjectOf(WC.Handle, 1, FilePIDL[0], IID_IContextMenu, nil, Pointer(ICMenu)); End. Else. Begin. // Получаем указатель на папку "Мой компьютер". If (Desktop.ParseDisplayName(WC.Handle, nil, StringToOleStr(CommonDir), PchEaten, PathPIDL, Attr) <> S_OK) or. (Desktop.BindToObject(PathPIDL, nil, IID_IShellFolder, Pointer(ShellFolder)) <> S_OK) then RaiseLastOSError; // Получаем указатель на файл. ShellFolder.ParseDisplayName(WC.Handle, nil, StringToOleStr(FileName), PchEaten, FilePIDL[0], Attr); // Получаем указатель на контектсное меню файла. AResult := ShellFolder.GetUIObjectOf(WC.Handle, 1, FilePIDL[0], IID_IContextMenu, nil, Pointer(ICMenu)); End; // Если указатель на конт. меню есть, делаем так: If Succeeded(AResult) then. Begin. ICMenu2 := nil; // Создаем меню. ShellContextMenu := CreatePopupMenu; // Производим его наполнение. If Succeeded(ICMenu.QueryContextMenu(ShellContextMenu, 0, 1, $7FFF, CMF_EXPLORE)) and. Succeeded(ICMenu.QueryInterface(IContextMenu2, ICMenu2)) then. CallbackWindow := CreateMenuCallbackWnd(ICMenu2); Try. // Показываем меню. PopupMenuResult := TrackPopupMenu(ShellContextMenu, TPM_LEFTALIGN or TPM_LEFTBUTTON. Or TPM_RIGHTBUTTON or TPM_RETURNCMD, MousePoint.X, MousePoint.Y, 0, CallbackWindow, nil); Finally. ICMenu2 := nil; End; // Если был выбран какой либо пункт меню: If PopupMenuResult then. Begin. // Индекс этого пункта будет лежать в ICmd. ICmd := LongInt(PopupMenuResult) - 1; // Заполняем структуру TCMInvokeCommandInfo. FillChar(CMD, SizeOf(CMD), #0); With CMD do. Begin. CbSize := SizeOf(CMD); HWND := WC.Handle; LpVerb := MakeIntResource(ICmd); NShow := SW_SHOWNORMAL; End; // Выполняем InvokeCommand с заполненной структурой. AResult := ICMenu.InvokeCommand(CMD); If AResult <> S_OK then RaiseLastOSError; End; End; Finally. // Освобождаем занятые ресурсы чтобы небыло утечки памяти. If FilePIDL[0] <> nil then. Begin. // Для освобождения использем IMalloc. SHGetMAlloc(M); If M <> nil then. M.Free(FilePIDL[0]); M:=nil; End; If PathPIDL <> nil then. Begin. SHGetMAlloc(M); If M <> nil then. M.Free(PathPIDL); M:=nil; End; If ShellContextMenu <>0 then. DestroyMenu(ShellContextMenu); If CallbackWindow <> 0 then. DestroyWindow(CallbackWindow); ICMenu := nil; ShellFolder := nil; Desktop := nil; If CoInit = S_OK then CoUninitialize; End; End; // Пример использования. Procedure TForm1.Button1Click(Sender: TObject); Var. Pt: TPoint; Begin. GetCursorPos(pt); GetProperties('E:\Guardant\INSTDRV.INI', pt, Self); End; End.

Взято из http://forum.sources.ru.

Автор: Rouse_

©Drkb::03146.

Контроль за изменением содержимого буфера обмена

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Memo1: TMemo; Procedure FormCreate(Sender: TObject); Procedure FormDestroy(Sender: TObject); Private. HwndNextViewer: THandle; Procedure WMChangeCbChain(var Message: TWMChangeCBChain); message WM_CHANGECBCHAIN; Procedure WMDrawClipboard(var Message: TMessage); message WM_DRAWCLIPBOARD; End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.FormCreate(Sender: TObject); Begin. // Add the window to the clipboard viewer chain. HwndNextViewer := SetClipboardViewer(Handle); Memo1.Lines.Clear. End; Procedure TForm1.WMChangeCbChain(var Message: TWMChangeCBChain); Begin. With Message do. Begin. // If the next window is closing, repair the chain. If Remove = hwndNextViewer then. HwndNextViewer := Next. // Otherwise, pass the message to the next link. Else. If hwndNextViewer <> 0 then. SendMessage(hwndNextViewer, Msg, Remove, Next); End; End; // clipboard contents changed. Procedure TForm1.WMDrawClipboard(var Message: TMessage); Begin. // Pass the message to the next window in clipboard. // viewer chain. Memo1.Lines.Add('Сhаngеd'); With Message do. SendMessage(hwndNextViewer, Msg, WParam, LParam); End; Procedure TForm1.FormDestroy(Sender: TObject); Begin. ChangeClipboardChain(Handle, hwndNextViewer); End; End. Автор: Александр (Rouse_) Багель

Взято из http://forum.sources.ru.

©Drkb::01875.

Code: { An application can be notified of changes in the data stored in the. Windows clipboard by registering itself as a Clipboard Viewer. Clipboard viewers use two API calls and several messages to communicate. With the Clipboard viewer chain. SetClipboardViewer adds a window to the. Beginning of the chain and returns a handle to the next viewer in the chain. ChangeClipboardChain removes a window from the chain. When a clipboard change occurs, The first window in the clipboard viewer chain is notified via the WM_DrawClipboard. Message and must pass the message on to the next window. To do this, our application. Must store the next window along in the chain to forward messages to and also respond. To the WM_ChangeCBChain message which is sent whenever any other clipboard viewer on. The system is added or removed to ensure the next window along is valid. } Unit Unit1; Interface. Uses. Windows, Messages, Forms, Classes, Controls, StdCtrls; Type. TForm1 = class(TForm). Button1: TButton; Button2: TButton; Procedure Button1Click(Sender : TObject); Procedure Button2Click(Sender : TObject); Procedure FormCreate(Sender : TObject); Procedure FormDestroy(Sender : TObject); Private. FNextClipboardViewer: HWND; Procedure WMChangeCBChain(var Msg : TWMChangeCBChain); message WM_CHANGECBCHAIN; Procedure WMDrawClipboard(var Msg : TWMDrawClipboard); message WM_DRAWCLIPBOARD; End; Var. Form1 : TForm1; Implementation. {$R *.DFM}. Procedure TForm1.FormCreate(Sender : TObject); Begin. { Initialize variable }. FNextClipboardViewer := 0; End; Procedure TForm1.Button1Click(Sender : TObject); Begin. If FNextClipboardViewer <> 0 then. MessageBox(0, 'This window is already registered!', nil, 0). Else. { Add to clipboard chain }. FNextClipboardViewer := SetClipboardViewer(Handle); End; Procedure TForm1.Button2Click(Sender : TObject); Begin. { Remove from clipboard chain }. ChangeClipboardChain(Handle, FNextClipboardViewer); FNextClipboardViewer := 0; End; Procedure TForm1.WMChangeCBChain(var Msg : TWMChangeCBChain); Begin. Inherited; { mark message as done }. Msg.Result := 0; { the chain has changed }. If Msg.Remove = FNextClipboardViewer then. { The next window in the clipboard viewer chain had been removed. We recreate it. }. FNextClipboardViewer := Msg.Next. Else. { Inform the next window in the clipboard viewer chain }. SendMessage(FNextClipboardViewer, WM_CHANGECBCHAIN, Msg.Remove, Msg.Next); End; Procedure TForm1.WMDrawClipboard(var Msg : TWMDrawClipboard); Begin. Inherited; { Clipboard content has changed }. Try. MessageBox(0, 'Clipboard content has changed!', 'Clipboard Viewer', MB_ICONINFORMATION); Finally. { Inform the next window in the clipboard viewer chain }. SendMessage(FNextClipboardViewer, WM_DRAWCLIPBOARD, 0, 0); End; End; Procedure TForm1.FormDestroy(Sender : TObject); Begin. If FNextClipboardViewer <> 0 then. Begin. { Remove from clipboard chain }. ChangeClipboardChain(Handle, FNextClipboardViewer); FNextClipboardViewer := 0; End; End; End.

©Drkb::01876.

Взято с сайта: http://www.swissdelphicenter.ch.

Инспектор объектов и метаданные

Предмет данной статьи - инспектор объектов как средство, доступное конечному пользователю некоторой прикладной программы. Само понятие "инспектор" трактуется в данном случае очень широко: инспектор - это инструмент прикладной программы, с помощью которого пользователь может посмотреть и изменить свойства тех объектов, с которыми он работает. Отметим, что речь идет о любых объектах прикладного уровня, а не только о визуальных компонентах (как в Delphi).

Мотивация и постановка задачи

При попытке сформулировать требования к инспектору объектов у меня получился такой список :

· инспектор должен иметь возможность работать с объектами любых типов. Не предполагается происхождение объектов от какого-либо специального базового класса,

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

· инспектируемые объекты могут выглядеть по-разному для разных пользователей или разных контекстов и могут предоставлять для инспекции различные наборы своих свойств. Например, с прикладной программой могут работать пользователи различных категорий: "новичок", "обычный пользователь", "эксперт". Естественно, что "эксперту" доступно большее число инспектируемых свойств, чем "новичку",

· объекты могут иметь сложную внутреннюю структуру, то есть, содержать вложенные объекты, которые, в свою очередь, также могут иметь вложенные объекты. Вложенность объектов неограничена (в разумных пределах),

· число инспектируемых свойств может быть достаточно большим, при этом должны существовать средства иерархической упорядоченности, то есть, свойства могут быть представлены, в общем случае, как элементы дерева, веточки которого можно сворачивать и разворачивать,

· инспектор должен сохранять историю работы с различными объектами, то есть, при повторе инспекции объекта, внешний вид дерева его свойств должен быть таким же, как и при последней инспекции. Это означает, что инспектор должен сохранять историю сворачивания и разворачивания веточек,

· имена свойств могут быть на любом языке, например, на русском, и могут включать произвольный набор символов. Имена могут иметь достаточно большую длину и составляться из нескольких слов,

· должна существовать развитая система помощи, включающая, как минимум, два уровня по каждому инспектируемому свойству - подсказка и справка,

· реализация всех этих условий не должна быть связана с большими трудозатратами со стороны программиста.

Может показаться, что это завышенный набор требований, но, тем не менее, все перечисленные пункты были не придуманы, а продиктованы той реальной необходимостью, которую мне пришлось учитывать в одном из выполняемых мною проектов.

Как видно из перечисленных выше требований, объекты должны обладать существенно большим набором аттрибутов, чем это требуется нам, программистам, для работы с объектами внутри программного кода. Для обозначения этой дополнительной информации будем использовать термин "метаданные" или "аттрибуты". Приставка "мета" подчеркивает, что это данные, описывающие другие данные, то есть, "данные о данных". Именно такие термины используются в языке C# и в платформе .Net. Примером метаданных является информация RTTI, которую формирует компилятор Delphi. Очевидно также, что метаданные, формируемые Delphi недостаточны для удовлетворения всех поставленных требований, а такая возможность, как описание своих аттрибутов (доступная в C#), в Delphi отсутствует. Кроме того, нужно удовлетворить указанному выше требованию о том, что инспектор должен работать и с такими объектами, которые не были спроектированы в расчете на инспекцию.

При анализе поставленных требований я выделил четыре основные задачи, необходимые для создания инспектора. Каждой из этих задач посвящен в статье свой раздел:

· создание метаданных, размещение метаданных и доступ к ним,

· создание прокси-объектов (заместителей), работающих с объектами различной природы и унифицирующих способ взаимодействия объектов с инспектором,

· создание менеджера объектов, который изолирует визуальный компонент инспектора от инспектируемых объектов и метаданных,

· создание собственно инспектора как визуального компонента.

Метаданные

Можно придумать, вероятно, много различных способов организации метаданных. Например, метаданные объектов различных типов можно описывать в отдельном файле (или файлах) в каком-либо формате, например, как текст на языке XML. Структура метаданных может быть в этом случае сколь угодно сложной и содержать такие крупные разделы, как категория пользователя или локализация. Файлы метаданных можно распространять вместе с программой или внести их в ресурсы, размещаемые в самой программе или в DLL. Для доступа к метаданным потребуется некоторого рода база или список метаданных, индексируемых именем типа, а также XML-парсер для разбора текста.

Я остановил свой выбор на таком способе - хранение метаданных в виде статических классов, регистрируемых в реестре метаданных. Статическими классами будем называть классы, которые содержат только классовые методы и ничего больше. Особенностью таких классов является то, что с ними можно работать без динамического инстанцирования экземляров во время выполнения. Метаданные вводятся как локальные константные записи, доступ к которым выполняется с помощью классовых методов. Все классы метаданных порождаются от базового статического класса TGsvObjectInspectorTypeInfo, виртуальные классовые методы которого переопределяются в классах метаданных. Определение TGsvObjectInspectorTypeInfo выглядит так:

Code: TGsvObjectInspectorTypeInfo = class. Public. Class function ObjectName(AObject: TObject): String; virtual; Class function TypeName: String; virtual; Class function TypeInfo: PGsvObjectInspectorPropertyInfo; virtual; Class function ChildrenInfo(Index: Integer): PGsvObjectInspectorPropertyInfo; virtual; Class procedure FillList(AObject: TObject; List: TStrings); virtual; Class procedure ShowDialog(Inspector: TComponent; Info: PGsvObjectInspectorPropertyInfo; Const EditRect: TRect); virtual; Class function IntegerToString(const Value: LongInt): String; virtual; Class function StringToInteger(const Value: String): LongInt; virtual; Class function CharToString(const Value: Char): String; virtual; Class function StringToChar(const Value: String): Char; virtual; Class function FloatToString(const Value: Extended): String; virtual; Class function StringToFloat(const Value: String): Extended; virtual; Class function ObjectToString(const Value: TObject): String; virtual; End;

Инсталляция/удаление сервисов под НТ.

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Инсталляция/удаление сервисов под НТ. Функции для создавания и удаления NT Services. Можно создать NT Service от текущее приложение. Параметры: 1. CreateNTService(ExecutablePath,ServiceName: String). ExecutablePath - Полный путь к изполнимого файла от которого создавается NT Service. ServiceName - Имя сервиза которое отобразится в Service Control Manager. Результат: True - если операциая завершена успешно. False - если есть ошибка. Можно произвести call то GetLastError чтобы информироваться об естество ошибки. 2. DeleteNTService(ServiceName: String):boolean; ServiceName - имя сервиза подлежающии удаления. Результат: True - если операциая завершена успешно. False - если есть ошибка. Можно произвести call то GetLastError чтобы. Информироваться об естество ошибки. Зависимости: WinSVC, Windows. Автор: Alex Kantchev, stoma@bitex.bg. Copyright: Собственное написание. Дата: 19 июня 2002 г. ********************************************** } // CreateNTService(ExecutablePath,ServiceName: String). // ExecutablePath - Полный путь к изполнимого файла от. // которого создавается NT Service. // ServiceName - Имя сервиза которое отобразится. // в Service Control Manager Результат: //Результат: // true - если операциая завершена успешно. // false - если есть ошибка. Можно произвести. // call то GetLastError чтобы информироваться об. // естество ошибки. Function CreateNTService(ExecutablePath,ServiceName: String):boolean; Var. HNewService,hSCMgr: SC_HANDLE; // Rights: DWORD; FuncRetVal: Boolean; Begin. FuncRetVal := False; HSCMgr := OpenSCManager(nil,nil,SC_MANAGER_CREATE_SERVICE); If (hSCMgr <> 0 ) then. Begin. //Custom service access rights may be built here. //we use GENERIC_EXECUTE which is combination of. //STANDARD_RIGHTS_EXECUTE, SERVICE_START, SERVICE_STOP, //SERVICE_PAUSE_CONTINUE, and SERVICE_USER_DEFINED_CONTROL. //You can create own rights and use them as shown in the. //commented line below. //Rights := STANDARD_RIGHTS_REQUIRED or SERVICE_START or SERVICE_STOP. // or SERVICE_QUERY_STATUS or SERVICE_PAUSE_CONTINUE or. // SERVICE_INTERROGATE; HNewService := CreateService(hSCMgr,PChar(ServiceName),PChar(ServiceName), STANDARD_RIGHTS_REQUIRED,SERVICE_WIN32_OWN_PROCESS, SERVICE_DEMAND_START,SERVICE_ERROR_NORMAL, PChar(ExecutablePath),nil,nil,nil,nil,nil); CloseServiceHandle(hSCMgr); If (hNewService <> 0) then. FuncRetVal := true. Else. FuncRetVal := false; End; CreateNTService := FuncRetVal; End; // *** //DeleteNTService(ServiceName: String):boolean; // ServiceName - имя сервиза подлежающии удаления. //Результат: // true - если операциая завершена успешно. // false - если есть ошибка. Можно произвести call то GetLastError чтобы. // информироваться об естество ошибки. Function DeleteNTService(ServiceName: String):boolean; Var. HServiceToDelete,hSCMgr: SC_HANDLE; RetVal: LongBool; FunctRetVal: Boolean; Begin. FunctRetVal := false; HSCMgr := OpenSCManager(nil,nil,SC_MANAGER_CREATE_SERVICE); If (hSCMgr <> 0 ) then. Begin. HServiceToDelete := OpenService(hSCMgr, PChar(ServiceName), SERVICE_ALL_ACCESS); RetVal := DeleteService(hServiceToDelete); CloseServiceHandle(hSCMgr); FunctRetVal := RetVal; End; DeleteNTService := FunctRetVal; End;

Инсталляция Screen Saver.

Code: Uses. Shellapi; Procedure InstallScreenSaver(const FileName: string); Begin. { Set this screensaver as default screensaver and open the properties dialog}. ShellExecute(Application.Handle, 'open', PChar('rundll32.exe'), PChar('desk.cpl,InstallScreenSaver ' + FileName), nil, SW_SHOWNORMAL); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. InstallScreenSaver('c:\YourScreenSaverFile.scr'); End;

©Drkb::02381.

Взято с сайта: http://www.swissdelphicenter.ch.

Интерпретаторы

4. Интерпретаторы.

ВВЕДЕНИЕ.

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

Если эта серия о компиляторах, то почему мы должны беспокоиться об интерпретаторах? Просто я хочу чтобы вы увидели как изменяется характер синтаксического анализатора при изменении целей. Я также хочу объединить понятия этих двух типов трансляторов, чтобы вы могли видеть не только различия но и сходства.

Рассмотрим следующее присваивание:

X = 2 * y + 3.

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

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

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

Что я хотел бы, чтобы вы увидели, это то, что план… структура… синтаксического анализатора не меняется. Изменяются только действия. Так что, если вы можете написать интерпретатор для данного языка, то вы можете также написать и компилятор, и наоборот. Однако, как вы увидите, имеются и отличия, и значительные. Поскольку действия различны, процедуры, завершающие распознавание, пишутся по-разному. Характерно, что в интерпретаторе завершающие подпрограммы распознавания написаны как функции, возвращающие числовое значение вызвавшей их программе. Ни одна из подпрограмм анализа нашего компилятора не делает этого.

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

Я могу привести несколько примеров. Я уже упомянул один: большинство интерпретаторов, типа Microsoft BASIC, к примеру, транслируют исходный текст (токенизируют его) в промежуточную форму, чтобы было легче выполнять синтаксический анализ в реальном режиме времени.

Другой пример – ассемблер. Целью ассемблера, конечно, является получение объектного кода и он обычно выполняет это по однозначному принципу: одна инструкция на строку исходного кода. Но почти все ассемблеры также разрешают использовать выражения как параметры. В этом случае выражения всегда являются константами, и ассемблер не предназначен выдавать для них объектный код. Скорее он "интерпретирует" выражение и вычисляет соответствующее значение, которое фактически и выдается с объектным кодом.

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

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

К примеру, для данного выражения.

X = x + 3 - 2 - (5 - 4).

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

X = x + 0.

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

X = x,

Что совсем не требует никаких действий. Мы смогли уменьшить 18 инструкций до нуля!

Обратите внимание, что нет никакой возможности оптимизировать таким способом наш компилятор, потому что каждое действие выполняется в нем немедленно.

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

Так как мы действуем в основном по принципу KISS, я не буду более углубляться в эту тему. Я только хочу, чтобы вы знали, что вы можете получить некоторую оптимизацию кода, объединяя методы компиляции и интерпретации. В частности Вы должны знать, что подпрограммы синтаксического анализа в более интеллектуальном трансляторе обычно что-то возвращают вызвавшей их программе и иногда сами ожидают этого. Эта главная причина обсуждения интерпретаторов в этой главе.

ИНТЕРПРЕТАТОР.

Итак, теперь, когда вы знаете почему мы принялись за все это, давайте начнем. Просто для того, чтобы дать вам практику, мы начнем с пустого Cradle и создадим транслятор заново. На этот раз, конечно, мы сможем двигаться немного быстрее.

Так как сейчас мы собираемся выполнять арифметические действия, то первое, что мы должны сделать – изменить функцию GetNum, которая до настоящего момента всегда возвращала символ (или строку). Лучше если сейчас она будет возвращать целое число. Сделайте копию Cradle (на всякий случай не изменяйте сам Cradle!!) и модифицируйте GetNum следующим образом:

Code: { Get a Number }. Function GetNum: integer; Begin. If not IsDigit(Look) then Expected('Integer'); GetNum := Ord(Look) - Ord('0'); GetChar; End;

Затем напишите следующую версию Expression:

Code: { Parse and Translate an Expression }. Function Expression: integer; Begin. Expression := GetNum; End;

И, наконец, вставьте.

Writeln(Expression);

В конец основной программы. Теперь откомпилируйте и протестируйте.

Все, что эта программа делает - это "анализ" и трансляция "выражения", состоящего из одиночного целого числа. Как обычно, вы должны удостовериться, что она обрабатывает числа от 0 до 9 и выдает сообщение об ошибке для чего-либо другого. Это не должно занять у вас много времени!

Теперь давайте расширим ее, включив поддержку операций сложения. Измените Expression так:

Code: { Parse and Translate an Expression }. Function Expression: integer; Var Value: integer; Begin. If IsAddop(Look) then. Value := 0. Else. Value := GetNum; While IsAddop(Look) do begin. Case Look of. '+': begin. Match('+'); Value := Value + GetNum; End; '-': begin. Match('-'); Value := Value - GetNum; End; End; End; Expression := Value; End;

Структура Expression, конечно, схожа с тем, что мы делали ранее, так что мы не будем иметь слишком много проблем при ее отладке. Тем не менее это была серьезная разработка, не так ли? Процедуры Add и Subtract исчезли! Причина в том, что для выполнения необходимых действий нужны оба аргумента операции. Я мог бы сохранить эти процедуры и передавать в них значение выражения на данный момент, содержащееся в Value. Но мне показалось более правильным оставить Value как строго локальную переменную, что означает, что код для Add и Subtract должен быть помещен вместе. Этот результат наводит на мысль, что хотя разработанная нами структура была хорошей и проверенной для нашей бесхитростной схемы трансляции, она возможно не могла бы использоваться с ленивой оценкой. Эту небольшую интересную новость нам возможно необходимо иметь в виду в будущем.

Итак, транслятор работает? Тогда давайте сделаем следующий шаг. Несложно понять, что процедура Term должна выглядеть также. Замените каждый вызов GetNum в функции Expression на вызов Term и затем наберите следующую версию Term:

Code: { Parse and Translate a Math Term }. Function Term: integer; Var Value: integer; Begin. Value := GetNum; While Look in ['*', '/'] do begin. Case Look of. '*': begin. Match('*'); Value := Value * GetNum; End; '/': begin. Match('/'); Value := Value div GetNum; End; End; End; Term := Value; End;

Интерфейсы и плагины.

Интерфейсы и плагины

Введение Пожалуй, каждому программисту со временем приходит в голову мысль, что его замечательной программе не хватает гибкости. И действительно, допустим, есть большая программа, и в нее понадобилось внести небольшие изменения. Не важно, по какой причине. Но для этого ее надо откомпилировать, проверить, а потом еще и поставить на рабочие места. Нет нужды говорить, что это достаточно долгое занятие. В другом случае может возникнуть желание, чтобы другие программисты могли расширять функциональность программы, а когда программа - единое целое, то им надо полностью поставить исходный код, еще и с описанием, где что находится, какие библиотеки нужны и так далее. И программист приходит к выводу, что очень желательно, чтобы его программа состояла из набора отдельных модулей (плагинов), каждый из которых был бы независим от других. Тогда при необходимости можно изменить и отладить только один модуль, а сторонним программистам дать шаблон интерфейса. Программ, построенных таким образом, множество, и остается только завидовать. Чаще всего модульность реализуется на основе механизмов dll, динамических библиотек. Вот только со стандартной dll возникают трудности: экспортируются только процедуры, да и ansistring не так просто передать. А хочется ведь передавать в модули и объекты. Конечно, это возможно, но... С этого момента плагины можно писать только на Delphi, и, мало того, именно на той версии, с которой начиналась разработка, никто ведь не гарантирует, что внутреннее представление объекта не поменяется с изменением версии среды разработки. И, как ни странно, мало кто обращает внимание на механизм, который есть в любой современной версии Windows, и который предназначен прежде всего именно для взаимодействия модулей и программ. Я имею в виду COM. И если учесть, что в Delphi работа с COM является достаточно простым делом, очень странным кажется тот факт, что в большинстве случаев применение этой технологии ограничивается, например, выдачей в Excel отчетов или работой с TWebBrowser. Но эта технология позволяет легко создавать модульные приложения, и с достаточно низкими затратами. Все, что нужно - реализовать интерфейсы к объектам, и обмениваться этими интерфейсами. И совершенно не важно, на какой версии Delphi написан плагин, фактически, он может быть написан вообще на другом языке программирования: COM не зависит от языка. При этом СОМ - объектная технология, тесно интегрированная в Delphi. Я хочу показать, как можно с помощью COM решить задачу создания плагинов, маленьких частей программы, которые могут быть изменены независимо от основной программы. В частности, здесь я рассматриваю, как создать несколько библиотек, по-разному реализующих одну и ту же функциональность. Итак, что же такое интерфейсы и с чем их едят? Говоря простым языком, интерфейс COM - это всего лишь структура, которая содержит объявления методов. И не более того. Ближайший аналог в Delphi - объявление класса. Для создания плагинов нужно понимать, что у интерфейса нет экземпляра, это просто декларация, которая может быть понята на любом языке программирования, в котором есть возможность работы с COM. Собственно код и данные должны содержаться в объекте, который реализует этот интерфейс, для него даже есть специальное название, кокласс (coclass). И может быть сколько угодно коклассов, реализующих один и тот же интерфейс. Единый интерфейс с различным наполнением - как раз то, что нужно. То есть, нужно просто создать ту реализацию интерфейса, которая нужна, а дальше просто общаться с ней через интерфейс, который везде одинаков. Давайте рассмотрим конкретный пример. Для этого я взял три метода сортировки массива, которые нагло утянул из проекта в demos\threads. Это BubbleSort, SelectionSort и QuickSort. Потоки и визуализацию рассматривать не будем, по крайней мере, сейчас. Задача стоит в том, чтобы создать три плагина для сортировки массива, реализующих каждый свой метод, и подключать один из них по мере надобности. Разумеется, каждая реализация должна находиться в своей библиотеке (dll). Объекты СОМ Сначала рассмотрим простейший способ. Как можно догадаться, прежде всего нам понадобится интерфейс. Затем - библиотека, содержащая его реализацию. Я предлагаю начать с библиотеки, так удобнее. При этом я не буду выдавать подробные инструкции вроде "мееедленно подведите указатель мышки к пункту меню File...", я просто покажу, что нужно:

В технологиии COM используются библиотеки специального вида, и при выборе ActiveX Library как раз создается шаблон такой библиотеки. Далее, сразу создаем COM Object с этой же вкладки, при этом среда спрашивает, что именно нужно. Вот это:

Можно догадаться, что первым будет реализован метод пузырька. Обратите внимание, что Type Library не нужна. В библиотеку добавляется модуль, в котором уже объявлен класс, потомок TComObject. Не хватает только интерфейса. И, поскольку библиотеки типов нет, нужно объявить его вручную, и, желательно, в отдельном модуле для дальнейшего использования. Но предварительно надо сохранить то, что получилось. Я дал название библиотеке BubbleLib, а модулю кокласса - CBubble. Теперь добавим модуль с интерфейсом:

Code: Unit SortIntf; Interface. Type. ISortIntf = interface. ['{BE229ED0-BA7B-11DA-B665-00508B0973BE}']. Procedure Sort(var A: Variant); stdcall; End; Implementation. End.

Каждый интерфейс идентифицируется своим номером, GUID, который написан в первой его строке. Чтобы его получить, достаточно нажать Ctrl+Shift+G. При этом среда вызывает функцию CoCreateGUID и вставляет его в позицию курсора. Разумеется, при каждом новом вызове выдается новый GUID. Часто GUID интерфейса называют IID, идентификатор интерфейса. Это делается для того, чтобы отличать идентификатор интерфейса от, например, идентификатора кокласса, который обычно называют CLSID. Можно заметить, что в метод передается почему-то Variant, а никак не массив. К сожалению, здесь действуют те же правила, что и с обычной dll: передавать только безопасные типы данных. Вот я и собираюсь передавать Safe array. Теперь в модуле CBubble дописываем его реализацию (не забыв добавить SortIntf в секцию uses):

Code: Type. TBubbleSort = class(TComObject, ISortIntf). Protected. Procedure Sort(var A: Variant); stdcall; End;

И в разделе implementation:

Code: Uses ComServ, Variants; { TBubbleSort }. Procedure TBubbleSort.Sort(var A: Variant); Var. I, J, T: Integer; HighBound, LowBound: integer; Begin. HighBound := VarArrayHighBound(A, 1); LowBound := VarArrayLowBound(A, 1); For I := HighBound downto LowBound do. For J := LowBound to HighBound - 1 do. If A[J] > A[J + 1] then. Begin. T := A[J]; A[J] := A[J + 1]; A[J + 1] := T; End; End;

Я не стал вызывать VarArrayLock, хотя это ускорило бы работу. Весь этот пример создается как простейшая иллюстрация создания и реализации интерфейсов, и не более того. После написания кода остается только вызвать Register ActiveX server для регистрации библиотеки как сервера COM. При этом в моей версии Delphi 6 почему-то создается файл BubbleLib_TLB.pas и в файл проекта записывается строка {$R *.tlb}. Одновременно создается библиотека типов, которая совершенно не нужна. Я так и не нашел причины, по которой она создается. Можно просто удалить файлы BubbleLib.tlb, BubbleLib_TLB.pas и убрать эту строку. Я так и сделал, причем перерегистрировать библиотеку не требуется. Регистрация требуется только если изменились идентификаторы интерфейсов или добавлены новые: все они должны быть записаны в реестре. Две оставшиеся библиотеки создаются абсолютно аналогично, только, разумеется, модуль SortIntf просто подключается к проекту. Для иллюстрации того, как можно использовать эти три компонента, я сделал маленькое приложение, которое назвал BubbleTest. Создал я его сразу после реализации первой библиотеки, а потом решил не менять название. Это обычное приложение с единственной формой, на которую я кинул TMemo, TSpinEdit, TListBox и кнопку. Мемо - для отображения массива, лист - для списка классов, ну а остальное - подручные стредства. Кроме этого, к проекту надо опять же подключить модуль SortIntf, чтобы программа знала, с каким интерфейсом придется работать. А для создания списка классов я просто перенес константы с CLSID (идентификаторами коклассов) из каждой библиотеки в модуль формы. После этого - несколько обработчиков:

Code: Const. Class_BubbleSort: TGUID = '{CFB8F671-BA45-11DA-B665-00508B0973BE}'; Class_SelectionSort: TGUID = '{BE229ED3-BA7B-11DA-B665-00508B0973BE}'; Class_QuickSort: TGUID = '{BE229ED4-BA7B-11DA-B665-00508B0973BE}'; Implementation. Uses COMObj, SortIntf; {$R *.dfm}. Procedure TForm1.Button1Click(Sender: TObject); Var. Bubble: ISortIntf; I: integer; A: Variant; HighBound, LowBound: integer; Class_ID: TGUID; ElemCount: integer; Begin. //Получаем нужный CLSID. Class_ID := StringToGUID(ListBox1.Items[ListBox1.ItemIndex]); //Создаем класс по этому CLSID и сразу просим у него интерфейс ISortIntf. Bubble := CreateCOMObject(Class_ID) as ISortIntf; ElemCount := SpinEdit1.Value; //Массив создаем и записываем в мемо. A := VarArrayCreate([0,ElemCount-1], varInteger); Memo1.Lines.Clear; HighBound := VarArrayHighBound(A, 1); LowBound := VarArrayLowBound(A, 1); For i := LowBound to HighBound do. Begin. A[i] := random(300); Memo1.Lines.Add(IntToStr(A[i])); End; //А вот, собственно, и вызов метода плагина. Bubble.Sort(A); //Остается показать результат. Memo1.Lines.Add('Sorted'); HighBound := VarArrayHighBound(A, 1); LowBound := VarArrayLowBound(A, 1); For i := LowBound to HighBound do. Begin. Memo1.Lines.Add(IntToStr(A[i])); End; End; Procedure TForm1.FormShow(Sender: TObject); Begin. With ListBox1.Items do. Begin. Clear; Add(GUIDToString(Class_BubbleSort)); Add(GUIDToString(Class_SelectionSort)); Add(GUIDToString(Class_QuickSort)); End; ListBox1.ItemIndex := 0; End;

Сама форма у меня в результате получилась такая:

Теперь можно выбрать любую из трех строк в списке, и при нажатии на кнопку будет загружен нужный плагин, и вызван его метод Sort для сортировки случайного массива из 10 элементов. Собственно, это и все. Освобождать интерфейс явне не надо, при выходе из обработчика интерфейс будет освобожден, и библиотека с коклассом выгрузится. Если нужно освободить интерфейс явно, достаточно присвоить Bubble := nil (интерфейс - это указатель, почти) или просто присвоить ему другой интерфейс. Список CLSID я создал попутно просто для иллюстрации, как обращаться с GUID. Можно догадаться, что в этот список можно загрузить строки, например, из текстового файла, и копирование констант из библиотек прямо в код приложения будет не нужно. Теперь посмотрим, что получилось. На первый взгляд, сделанное очень мало отличается от использования трех обычных библиотек, экспортирующих каждая свой метод Sort. Однако, есть и преимущества: во-первых, для работы теста не нужно знать где находится библиотека и как она называется. Нужен только идентификатор нужного класса. Во-вторых, не нужно заботиться о загрузке и выгрузке этой библиотеки, можете быть уверены, что она загрузится когда будет нужна и выгрузится, когда все интерфейсы освободятся. В-третьих, все-таки мы работаем с объектом, хоть и содержащим только один метод. В-четвертых, не нужно заботиться об уничтожении созданного объекта, Delphi делает это автоматически. Далее я рассмотрю, как можно использовать объекты и интерфейсы более полноценным образом. Автоматизация Разумеется, нельзя не заметить, что все еще имеются некоторые тонкости в использовании плагинов. Все еще нужен модуль с описанием интерфейса, который используется везде, где есть этот интерфейс. Это неудобно тем, что при создании плагина на других языках это описание придется переводить. О CLSID я не говорю: хотя он нужен для создания класса, его всегда можно передать в виде строки. Наконец, въедливый программист может спросить об обработке ошибок в методе Sort. Что будет, если подать на вход не массив, а обычный variant, например, со строкой? Будет выдано исключение, из которого можно понять только его тип, модуль, в котором оно произошло, и адрес. Это не слишком удобно. Потому я хочу предложить сделать все по-другому. Помните, я в свое время говорил, что type library не нужна? Использовать ее конечно не обязательно, но очень удобно. Фактически, библиотека типов выполняет почти ту же роль, что и файл SortIntf.pas, но при этом содержит в себе еще и дополнительную информацию, например, описание кокласса. При этом все объявления в библиотеке типов не зависят от языка программирования. Кроме всего сказаного, в VCL содержится множество классов, работающих именно с библиотекой типов и обеспечивающих дополнительные функции, в том числе и обработку исключений. Но перед тем, как начинать работу с бибиотекой типов, рекомендуется все хорошо обдумать. Дело в том, что библиотека типов будет использоваться подобно SortIntf.pas, то есть везде, где нужно описание интерфейса. И в случае, когда потребуется изменить эти описания, потребуется повторное подключение этой библиотеки. Прежде всего, надо определить хотя бы примерный состав объектов, которые нужны. Например, в первой части происходила сортировка простого массива чисел. Но на практике сортируют обычно не просто числа, а записи или строки. Да что угодно, лишь бы эти объекты были сравнимы. Поэтому в метод сортировки лучше передавать не массив чисел, а массив объектов, которые должны просто знать, как сравнить себя с другим таким же объектом. Поскольку у нас COM, то вместо объектов будут использоваться, разумеется, интерфейсы. Что мне хочется: есть три метода сортировки, значит, надо создать три класса. Если каждый класс будет содержать методы работы с массивом, причем одинаковые, то весьма желательно выделить эту часть в отдельный модуль. Далее все три класса будут использовать то, что в нем есть. Таким образом, нам нужен интерфейс для представления массива и интерфейс для его сортировки. Начнем. По аналогии с созданием файла описания интерфейса создадим библиотеку типов. Отдельную от всего, в ней будут храниться только описания интерфейсов. Создать ее можно из той же вкладки ActiveX, элемент так и называется Type Library. Откроется редактор, и в него надо внести наши интерфейсы. При добавлении интерфейса он сразу является потомком IDispatch, как раз то, что требуется. Вот что у меня получилось в итоге:

Я объявил два интерфейса: IVector, обеспечивающий работу с массивом, и ISort, у которого есть один метод, принимающий на вход массив и сортирующий его. Кроме этого, есть перечисление CompareResult. Дело в том, что методу Sort совсем не обязательно самому сравнивать и переставлять элементы вектора, эти операции можно поручить самому вектору. Поэтому я ввел два метода, которые обеспечивают именно сравнение и перестановку элементов, принимая на вход их индексы. Вот как выглядит метод Compare:

Кстати, если список параметров выглядит непривычно, то это всего лишь потому, что у меня установлено отображение библиотеки типов на IDL, языке определения интерфейсов. По умолчанию же в Delphi стоит отображение в нотации паскаля. Но в IDL видно, что на самом деле результат любого метода имеет тип HResult. И менять его так просто нельзя, это - соглашение, принятое для интерфейсов автоматизации. Каждый метод должен вернуть свой код завершения. Ничего страшного, параметр Result имеет модификаторы out, retval, и при отображении все будет нормально и привычно (если, конечно, действует соглашение safecall). Вот, кстати, мои настройки:

Интерфейсы, кстати, создались именно дуальные, поэтому методы будут иметь модификатор safecall. Так вот, в результате работы метод Compare возвращает константу из набора CompareResult, которая показывает порядок элементов с индексами Index1 и Index2 относительно друг друга. Этого вполне достаточно для большинства методов сортировки. После того, как библиотека создана, ее надо сохранить и зарегистрировать. Регистрация - вторая справа иконка, с узнаваемым значком реестра. Собственно, все, что она делает - это именно регистрация библиотеки в реестре. После этого библиотеку можно закрыть и приступить к реализации этих интерфейсов. Путь прежний: создаем новую библиотеку типов. Вот только добавлять будем не COM Object, а Automation Object, который работает с библиотекой типов и реализует необходимую функциональность. Сначала создадим объект для интерфейса IVector:

Будет создан модуль, содержащий в себе класс с именем, как несложно догадаться, TVector, и реализующий интерфейс IVector. Вот только не тот интерфейс, что нам нужен. Дело в том, что для COM не так важны названия интерфейсов, как их идентификаторы. И вот IID этого интерфейса совсем другой. Поэтому открываем библиотеку типов этой ActiveX library (по-английски, а то какая-то тавтология получается) и нагло удаляем оттуда интерфейс IVector, оставив только кокласс Vector. Теперь, чтобы стал известен наш интерфейс, нужно сделать пару не таких уж тривиальных шагов: встать на корень дерева, открыть вкладку uses и в контекстном меню вкладки выбрать "Show all type libraries". Затем долго листать список, пока не наткнешься на библиотеку SortIntf, и выбрать ее. Если ее там нет, то надо ее зарегистрировать (см выше). После этого снова выбрать в меню пункт "Show selected". Все, интерфейс стал известен. Теперь нужно добавить этот интерфейс на вкладку Implements кокласса Vector:

Снова воспользовавшись контекстным меню. Проект, кстати, я назвал VectorLib. Вот и все, остается только нажать на кнопку обновления, и в модуле будут автоматически сгенерированы шаблоны для методов. Кроме, того, в каталоге проекта будет создан файл SortIntf_TLB.pas, представляющий собой описание нашей библиотеки на паскале. Его нужно подключить к проекту, и записать в секцию uses модуля. После этого можно реализовывать методы интерфейса:

Code: Unit CVector; {$WARN SYMBOL_PLATFORM OFF}. Interface. Uses. ComObj, ActiveX, VectorLib_TLB, StdVcl, SortIntf_TLB; Type. TVector = class(TAutoObject, IVector). Private. FArray: array of integer; Protected. Function Compare(Index1, Index2: Integer): CompareResult; safecall; Function Get_Count: Integer; safecall; Function Get_Elem(Index: Integer): OleVariant; safecall; Procedure Exchange(Index1, Index2: Integer); safecall; Procedure Set_Count(Value: Integer); safecall; Procedure Set_Elem(Index: Integer; Value: OleVariant); safecall; { Protected declarations }. End; Implementation. Uses ComServ; Function TVector.Compare(Index1, Index2: Integer): CompareResult; Begin. Result := crLower; If FArray[Index1] > FArray[Index2] then. Result := crGreater; If FArray[Index1] = FArray[Index2] then. Result := crEqual; End; Function TVector.Get_Count: Integer; Begin. Result := Length(FArray); End; Function TVector.Get_Elem(Index: Integer): OleVariant; Begin. Result := FArray[Index]; End; Procedure TVector.Exchange(Index1, Index2: Integer); Var. T: integer; Begin. T := FArray[Index1]; FArray[Index1] := FArray[Index2]; FArray[Index2] := T; End; Procedure TVector.Set_Count(Value: Integer); Begin. If Value <> Length(FArray) then. SetLength(FArray, Value); End; Procedure TVector.Set_Elem(Index: Integer; Value: OleVariant); Begin. FArray[Index] := Value; End; Initialization. TAutoObjectFactory.Create(ComServer, TVector, Class_Vector, CiMultiInstance, tmApartment); End.

Немного поясню. Хотя Count и Elem объявлены как свойства (property), их все равно надо реализовывать через методы

Get_... и Set_.... Просто потому, что у интерфейса, собственно говоря, данных нет, есть только методы. И, кстати, метод Compare приобрел вполне цивилизованный вид, как, впрочем, и все остальные. Это произошло именно из-за модификатора safecall. Реализацию я выбрал самую простую, через динамический массив. Не думаю что нужно комментировать код, все должно быть достаточно понятно. Свойство Elem имеет тип Variant, для универсальности. Теперь нужно опять зарегистрировать получившийся сервер, и у нас появится кокласс, который реализует вектор целых чисел. Вторая библиотека - реализация интерфейса ISort, который будет сортировать методом пузырька. Создается аналогично предыдущей, только на этот раз кокласс называем "Sort" и, подключив библиотеку SortIntf, реализуем интерфейс ISort:

Code: Unit CSort; {$WARN SYMBOL_PLATFORM OFF}. Interface. Uses. ComObj, ActiveX, SortLib_TLB, StdVcl, SortIntf_TLB; Type. TSort = class(TAutoObject, ISort). Protected. Procedure Sort(const Vector: IVector); safecall; { Protected declarations }. End; Implementation. Uses ComServ; Procedure TSort.Sort(const Vector: IVector); Var. I, J: Integer; Begin. For I := Vector.Count - 1 downto 0 do. For J := 0 to Vector.Count - 2 do. If Vector.Compare(J, J + 1) = crGreater then. Vector.Exchange(J, J + 1); End; Initialization. TAutoObjectFactory.Create(ComServer, TSort, Class_Sort, CiMultiInstance, tmApartment); End.

Как можно догадаться, это своеобразная реализация метода пузырька, несмотря на то, что модуль называется CSort. Так получилось, а переименовывать достаточно тяжело. И тут же возникает мысль, а дальше? Ну сделаем мы еще пару классов Sort, но понадобится же их как-то опознавать. А при подключении библиотеки можно было видеть, сколько всего есть библиотек типов в системе, не перебирать же их. Разумеется, способ выделить свои классы есть, и называется он Component Categories, то есть категории компонентов. Фактически, это просто способ записи группы интерфейсов в реестр, для которого есть встроенный механизм. И, разумеется, этот механизм основан на интерфейсах. Остается его только задействовать, и лучше всего регистрировать класс в категории одновременно с регистрацией сервера. На самом деле, это даже проще: при регистрации сервера ActiveX в системе вызываются методы UpdateRegistry всех имеющихся фабрик классов. Фабрика, разумеется, у нас создается, обратите внимание на секцию initialization выше. Нужно создать потомок этой фабрики, перекрыв метод UpdateRegistry:

Code: Unit SortFactory; Interface. Uses COMObj; Type. TSortAutoObjectFactory = class(TAutoObjectFactory). Public. Procedure UpdateRegistry(Register: boolean); override; End; Implementation. Uses ActiveX, SysUtils, SortConsts; { TSortAutoObjectFactory }. Procedure TSortAutoObjectFactory.UpdateRegistry(Register: boolean); Var. CatReg: ICatRegister; CatInfo: TCATEGORYINFO; Begin. Inherited; OleCheck(CoCreateInstance(CLSID_StdComponentCategoryMgr, nil, CLSCTX_INPROC_SERVER, ICatRegister, CatReg)); If Register then. Begin. CatInfo.catid := CATID_SortServer; CatInfo.lcid := $0419; StringToWideChar(Sort_CatDesc, CatInfo.szDescription, Length(Sort_CatDesc) + 1); OleCheck(CatReg.RegisterCategories(1, @CatInfo)); OleCheck(CatReg.RegisterClassImplCategories(ClassID, 1, @CATID_SortServer)); End else. Begin. OleCheck(CatReg.UnRegisterClassImplCategories(ClassID, 1, @CATID_SortServer)); DeleteRegKey(Format('CLSID\%s\Implemented Categories', [GUIDToString(ClassID)])); End; End; End.

Разумеется, категория тоже распознается по ее GUID, но кроме этого у нее есть и описание на нормальном языке. Обе этих константы я вынес в отдельный файл, по той причине, что все приложения должны знать, в какой категории искать классы сортировки:

Code: Unit SortConsts; Interface. Const. CATID_SortServer: TGUID = '{782D841E-BB21-11DA-B666-00508B0973BE}'; Sort_CatDesc = 'Библиотеки сортировки. Тестовый пример'; Implementation. End.

Теперь остается подменить тип библиотеки в модуле CSort:

Code: Initialization. TSortAutoObjectFactory.Create(ComServer, TSort, Class_Sort, CiMultiInstance, tmApartment); End.

Вот и все. Вторая библиотека, SelSortLib, создана аналогично, я покажу только метод Sort:

Code: Procedure TSort.Sort(const Vector: IVector); Var. I, J: Integer; Begin. For I := 0 to Vector.Count - 2 do. For J := Vector.Count - 1 downto I + 1 do. If Vector.Compare(I,J) = crGreater then. Vector.Exchange(I,J); End;

Если честно, третью мне создавать уже как-то и не хочется, тем более что для иллюстрации материала вполне достаточно. Перейдем сразу к тестовому приложению. Создаем обычное приложение с формой, и делаем Import Type library, выбрав из списка SortIntf... Хотя погодите. Для окончательной иллюстрации мне еще хочется реализовать вектор действительных чисел. Сделаю это я прямо в этом приложении. Впрочем, импорт ничему не мешает, сделал так сделал. Выбираем опять создание Automation Object, прямо в приложении, подключаем SortIntf, и реализуем IVector. Вот только создан-то объект, к которому можно обратиться снаружи, а мне это не нужно. Ничего, как говорится, нет Factory - нет кокласса (я немного переиначил). Но отключить ее не совсем правильно, нужно сделать еще пару действий: во-первых, поменять тип кокласса на TAutoIntfObject. Это класс, который реализует интерфейсы - потомки IDispatch (у нас именно такие), но при этом у него нет фабрики, то есть, кокласс должен создаваться непосредственно внутри приложения. Во-вторых, как ни странно, убрать type library с коклассом и все воспоминания о ней, то есть использование COMServ и использование модуля импорта библиотеки. И, разумеется, убрать строчку {$R *.tlb} из проекта. Этого достаточно. Теперь есть класс вектора, который недоступен снаружи, но полностью доступен самому приложению. Вот какой кокласс у меня получился:

Code: Unit CDVector; {$WARN SYMBOL_PLATFORM OFF}. Interface. Uses. ComObj, ActiveX, StdVcl, SortIntf_TLB; Type. TDVector = class(TAutoIntfObject, IVector). Private. FArray: array of Double; Protected. Function Compare(Index1, Index2: Integer): CompareResult; safecall; Function Get_Count: Integer; safecall; Function Get_Elem(Index: Integer): OleVariant; safecall; Procedure Exchange(Index1, Index2: Integer); safecall; Procedure Set_Count(Value: Integer); safecall; Procedure Set_Elem(Index: Integer; Value: OleVariant); safecall; { Protected declarations }. Public. Procedure FillRandom(Size: integer); End; Implementation. Function TDVector.Compare(Index1, Index2: Integer): CompareResult; Begin. Result := crLower; If FArray[Index1] > FArray[Index2] then. Result := crGreater; If FArray[Index1] = FArray[Index2] then. Result := crEqual; End; Function TDVector.Get_Count: Integer; Begin. Result := Length(FArray); End; Function TDVector.Get_Elem(Index: Integer): OleVariant; Begin. Result := FArray[Index]; End; Procedure TDVector.Exchange(Index1, Index2: Integer); Var. T: Double; Begin. T := FArray[Index1]; FArray[Index1] := FArray[Index2]; FArray[Index2] := T; End; Procedure TDVector.Set_Count(Value: Integer); Begin. If Value <> Length(FArray) then. SetLength(FArray, Value); End; Procedure TDVector.Set_Elem(Index: Integer; Value: OleVariant); Begin. FArray[Index] := Value; End; Procedure TDVector.FillRandom(Size: integer); Var. I: integer; Begin. SetLength(FArray, Size); For i := Low(FArray) to High(FArray) do. FArray[i] := Random; End; End.

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

Это - форма уже работающего приложения. А вот ее код:

Code: Unit FSort; Interface. Uses. Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Spin, SortIntf_TLB; Type. TForm1 = class(TForm). Memo1: TMemo; ListBox1: TListBox; BtnInt: TButton; BtnDouble: TButton; SpinEdit1: TSpinEdit; Procedure FormCreate(Sender: TObject); Procedure btnDoubleClick(Sender: TObject); Procedure btnIntClick(Sender: TObject); Private. Procedure ShowSort(Vector: IVector); { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation. Uses SortConsts, CDVector, COMObj, ActiveX, VectorLib_TLB; Procedure ListSortServers(List: TStrings); Var. EnumGUID: IEnumGUID; Fetched: Cardinal; Guid: TGUID; CatInfo: ICatInformation; Begin. List.Clear; OleCheck(CoCreateInstance(CLSID_StdComponentCategoryMgr, nil, CLSCTX_INPROC_SERVER, ICatInformation, CatInfo)); OleCheck(CatInfo.EnumClassesOfCategories(1, @CATID_SortServer, 0, nil, EnumGUID)); While EnumGUID.Next(1, Guid, Fetched) = S_OK do. Begin. //Переводим CLSID в более понятный вид. List.Add(ClassIDToProgID(Guid)); End; End; {$R *.dfm}. Procedure TForm1.FormCreate(Sender: TObject); Begin. ListSortServers(ListBox1.Items); If ListBox1.Items.Count > 0 then. ListBox1.ItemIndex := 0; End; Procedure TForm1.btnDoubleClick(Sender: TObject); Var. TypeLib: ITypeLib; Vector: IVector; VecObj: TDVector; I: integer; Begin. //Нужна библиотека типов, в которой описан IVector. OleCheck(LoadRegTypeLib(LIBID_SortIntf, 1, 0, 0, TypeLib)); VecObj := TDVector.Create(TypeLib, IVector); VecObj.FillRandom(SpinEdit1.Value); Vector := VecObj as IVector; VecObj := nil; //От греха. ShowSort(Vector); End; Procedure TForm1.btnIntClick(Sender: TObject); Var. Vector: IVector; I: integer; Begin. Vector := CoVector.Create; Vector.Count := SpinEdit1.Value; For i := 0 to Vector.Count - 1 do. Vector.Elem[i] := Random(300); ShowSort(Vector); End; Procedure TForm1.ShowSort(Vector: IVector); Var. I: integer; SortObj: ISort; ProgID: string; Begin. Memo1.Lines.Clear; For i := 0 to Vector.Count - 1 do. Memo1.Lines.Add(FormatFloat('##0.#####', Vector.Elem[i])); //Создаем выбранный класс сортировки и сортируем. ProgID := ListBox1.Items[ListBox1.ItemIndex]; SortObj := CreateComObject(ProgIDToClassId(ProgID)) as ISort; SortObj.Sort(Vector); Memo1.Lines.Add('Sorted'); For i := 0 to Vector.Count - 1 do. Memo1.Lines.Add(FormatFloat('##0.#####', Vector.Elem[i])); End; End.

Здесь, думаю, необходимы пояснения, и довольно подробные. ListSortServers перечисляет все классы, зарегистрированные в нашей категории, и записывает не непонятную строку CLSID, а более-менее воспринимаемую строку ProgID. Это именно та строка, которая подается в функцию CreateOleObject. Да-да, все интерфейсы у нас дуальные, так что вполне возможно позднее связывание, без всякого импорта библиотеки типов. Конечно, при этом вызовы методов идут гораздо дольше, зато не надо делать импорт библиотеки типов. Здесь же я импортировал и подключил библиотеку VectorLib, для того чтобы создать и использовать вектор целых чисел. Вектор же действительных чисел я получаю прямо из объекта, причем достаточно непривычным образом. Рассмотрим код подробно:

//Нужна библиотека типов, в которой описан IVector.

OleCheck(LoadRegTypeLib(LIBID_SortIntf, 1, 0, 0, TypeLib));

VecObj := TDVector.Create(TypeLib, IVector);

VecObj.FillRandom(SpinEdit1.Value);

Vector := VecObj as IVector;

VecObj := nil; //От греха

Чтобы создать объект типа TAutoIntfObject, в его конструктор нужно подать ссылку на интерфейс нужной библиотеки типов и IID того интерфейса, который он должен реализовать. Обычно в качестве первого параметра достаточно подать COMServer.TypeLib, но в данном случае это не подходит: библиотеки типов нет, а когда она была, все равно там не было описания IVector. Поэтому нужно непосредственно подать интерфейс SortIntf.tlb. К счастью, она зарегистрирована, и нужно ее просто загрузить с получением ее интерфейса. Это и делается в первой строке. Во второй строке создается экземпляр кокласса (компилятор преобразует интерфейс к его IID во втором параметре), и далее вызывается метод класса для заполнения массива. Затем уже из самого класса получается интерфейс IVector. VecObj := nil я написал специально. Дело в том, что при доступе через интерфейс кокласс, как правило, сам следит за тем, когда ему уничтожится, точнее, этим управляет интерфейс. Поэтому пользоватся одновременно и экземпляром класса, и его интерфейсом нужно крайне аккуратно. Остальные методы практически мало отличаются от первого примера, пожалуй, единственное отличие в том, что clsid получается из идентификатора программы. Если применяется позднее связывание, этого можно и не делать, вот, например, как можно переписать работу с массивом:

Code: Procedure TForm1.btnInt2Click(Sender: TObject); Var. V: variant; Sort: Variant; I: integer; Begin. V := CreateOleObject('VectorLib.Vector'); V.Count := SpinEdit1.Value; For i := 0 to V.Count - 1 do. V.Elem[i] := Random(300); Memo1.Lines.Clear; For i := 0 to V.Count - 1 do. Memo1.Lines.Add(FormatFloat('##0.#####', V.Elem[i])); Sort := CreateOleObject(ListBox1.Items[ListBox1.ItemIndex]); Sort.Sort(V); Memo1.Lines.Add('Sorted'); For i := 0 to V.Count - 1 do. Memo1.Lines.Add(FormatFloat('##0.#####', V.Elem[i])); End;

Конечно, позднее связывание менее эффективно, но зато этот метод дает возможность использовать классы в языках программирования, которые не поддерживают раннего связывания, например, в VBScript. К тому же, не требуется импортировать библиотеку типов, что может быть весьма удобным, если нужно написать всего несколько строк с использованием интерфейса. Заключение Подведем итоги. Я показал пару способов организовать приложение в виде отдельных специализированных частей, достаточно активно взаимодействующих друг с другом. Конечно, можно было реализовать эти классы более эффективно и гибко, но я думаю, что и написанного вполне достаточно для понимания общих принципов. Все остальное, при желании, можно найти в интернете. Я также не коснулся вопроса о том, как делать визуальные плагины на основе ActiveX Form, по той причине, что это предмет для особого разговора. Роман Игнатьев, 2006, romkin[at]pochta.ru

Взято из http://forum.sources.ru.

Автор: Romkin.

©Drkb::04563.

Интерфейс переноса Drag-and-Drop.

Интерфейс переноса и приема компонентов появился достаточно давно. Он обеспечивает взаимодействие двух элементов управления во время выполнения приложения. При этом могут выполняться любые необходимые операции. Несмотря на простоту реализации и давность разработки, многие программисты (особенно новички) считают этот механизм малопонятным и экзотическим. Тем не менее использование Drag-and-Drop может оказаться очень полезным и простым в реализации. Сейчас мы в этом убедимся.

Интерфейс присоединения Drag-and-Dock.

Эта возможность появилась в Delphi 4. Она "подсмотрена" опять-таки у разработчиков из Microsoft, внедривших плавающие панели инструментов в MS Office, Internet Explorer и другие продукты (рис. 27.2).

Информационная система.

Информационная система

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

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

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

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

Грачев А.Ю. Введение в СУБД Informix.

©Drkb::02443.

Информация о AVI файле (разбор заголовка AVI).

Информация о AVI файле (разбор заголовка AVI).

Code: Unit Unit1; {©Drkb v.3(2007): www.drkb.ru}. Interface. Uses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type. TForm1 = class(TForm). Memo1: TMemo; OpenDialog1: TOpenDialog; Button1: TButton; Procedure Button1Click(Sender: TObject); Public. Procedure ReadAviInfo(FileName: string); End; Var. Form1: TForm1; Implementation. {$R *.dfm}. Procedure TForm1.ReadAviInfo(FileName: string); Var. IFileHandle: Integer; // хэндл файла. // Для позмционирования в AVI файле. Aviheadersize: integer; Vheadersize: integer; Aviheaderstart: integer; Vheaderstart: integer; Aheaderstart: integer; Astrhsize: integer; // Временные переменные. TempTest: String[5]; TempSize: Integer; TempVcodec: String[5]; TempAcodec: integer; TempMicrosec: integer; TempLengthInFrames: integer; TempAchannels: integer; TempAsamplerate: integer; TempAbitrate: integer; //Выходные данные. Size: double; Length: string; Vcodec: string; Vbitrate: double; VWidth: integer; VHeight: integer; Fps: double; LengthInSec: double; Acodec: string; Abitrate: string; Begin. // Открываем. IFileHandle := FileOpen(FileName, fmOpenRead); // Грубая проверка на подлинность файла. FileSeek(iFileHandle, 7, 0); FileRead(iFileHandle, TempTest, 5); If copy(TempTest, 0, 4) <> 'AVI ' then. Begin. MessageDlg('Could not open ' + FileName + ' because it is not a valid video file', mtError, [mbOk], 0); Exit; End; // Размер файла. FileSeek(iFileHandle,4,0); FileRead(iFileHandle, TempSize, 4); // Размер хедера (needed to locate the audio part). FileSeek(iFileHandle,28,0); FileRead(iFileHandle, Aviheadersize, 4); // старт хедера (needed to locate the video part). Aviheaderstart := 32; // Милисекунды (1000000 / TempMicrosec = fps). FileSeek(iFileHandle,Aviheaderstart,0); FileRead(iFileHandle, TempMicrosec, 4); // Размер во фреймах. FileSeek(iFileHandle,Aviheaderstart + 16,0); FileRead(iFileHandle, TempLengthInFrames, 4); // Ширина. FileSeek(iFileHandle,Aviheaderstart + 32,0); FileRead(iFileHandle, VWidth, 4); // Высота. FileSeek(iFileHandle,Aviheaderstart + 36,0); FileRead(iFileHandle, VHeight, 4); FileSeek(iFileHandle,Aviheaderstart + Aviheadersize + 4,0); FileRead(iFileHandle, Vheadersize, 4); Vheaderstart := Aviheaderstart + Aviheadersize + 20; // кодек. FileSeek(iFileHandle,Vheaderstart + 3,0); FileRead(iFileHandle, TempVCodec, 5); Aheaderstart := Vheaderstart + Vheadersize + 8; FileSeek(iFileHandle,Aheaderstart - 4,0); FileRead(iFileHandle, Astrhsize, 5); // Audio codec. FileSeek(iFileHandle,Aheaderstart + Astrhsize + 8,0); FileRead(iFileHandle, TempACodec, 2); // Audio каналы (1 = mono, 2 = stereo). FileSeek(iFileHandle,Aheaderstart + Astrhsize + 10,0); FileRead(iFileHandle, TempAchannels, 2); // Audio samplerate. FileSeek(iFileHandle,Aheaderstart + Astrhsize + 12,0); FileRead(iFileHandle, TempAsamplerate, 4); // Audio bitrate. FileSeek(iFileHandle,Aheaderstart + Astrhsize + 16,0); FileRead(iFileHandle, TempAbitrate, 4); // закрываем файл. FileClose(iFileHandle); // анализируем видео кодек (можно добавить больше). Vcodec := copy(TempVcodec, 0, 4); If Vcodec = 'div2' then Vcodec := 'MS MPEG4 v2' Else if Vcodec = 'DIV2' then Vcodec := 'MS MPEG4 v2' Else if Vcodec = 'div3' then Vcodec := 'DivX;-) MPEG4 v3' Else if Vcodec = 'DIV3' then Vcodec := 'DivX;-) MPEG4 v3' Else if Vcodec = 'div4' then Vcodec := 'DivX;-) MPEG4 v4' Else if Vcodec = 'DIV4' then Vcodec := 'DivX;-) MPEG4 v4' Else if Vcodec = 'div5' then Vcodec := 'DivX;-) MPEG4 v5' Else if Vcodec = 'DIV5' then Vcodec := 'DivX;-) MPEG4 v5' Else if Vcodec = 'divx' then Vcodec := 'DivX 4' Else if Vcodec = 'mp43' then Vcodec := 'Microcrap MPEG4 v3'; // тоже с аудио. Case TempAcodec of. 0: Acodec := 'PCM'; 1: Acodec := 'PCM'; 85: Acodec := 'MPEG Layer 3'; 353: Acodec := 'DivX;-) Audio'; 8192: Acodec := 'AC3-Digital'; Else. Acodec := 'Unknown (' + IntToStr(TempAcodec) + ')'; End; Case (Trunc(TempAbitrate / 1024 * 8)) of. 246..260: Abitrate := '128 Kbit/s'; 216..228: Abitrate := '128 Kbit/s'; 187..196: Abitrate := '128 Kbit/s'; 156..164: Abitrate := '128 Kbit/s'; 124..132: Abitrate := '128 Kbit/s'; 108..116: Abitrate := '128 Kbit/s'; 92..100: Abitrate := '128 Kbit/s'; 60..68: Abitrate := '128 Kbit/s'; Else. Abitrate := FormatFloat('# Kbit/s', TempAbitrate / 1024 * 8); End; // тут некоторые вычисления. Size := TempSize / 1024 / 1024; Fps := 1000000 / TempMicrosec; // FPS. LengthInSec := TempLengthInFrames / fps; // Length in seconds. Length := FormatFloat('# min', Int(LengthInSec / 60)) + FormatFloat(' # sec', Round(LengthInSec - (Int(LengthInSec / 60) * 60))); Vbitrate := (TempSize / LengthInSec - TempABitrate) / 1024 * 8; // Выводим инфу в мемо. Memo1.Lines.Add('AVI INFORMATION'); Memo1.lines.Add('Size: ' + FormatFloat('#.## MB',Size)); Memo1.Lines.Add('Length: ' + Length); Memo1.Lines.Add(''); Memo1.Lines.Add('VIDEO INFORMATION'); Memo1.Lines.Add('Codec: ' + Vcodec); Memo1.Lines.Add('Bitrate: ' + FormatFloat('# Kbit/s', Vbitrate)); Memo1.lines.Add('Width: ' + IntToStr(VWidth) + ' px'); Memo1.lines.Add('Height: ' + IntToStr(VHeight) + ' px'); Memo1.Lines.Add('FPS: ' + FormatFloat('#.##', fps)); Memo1.Lines.Add(''); Memo1.Lines.Add('AUDIO INFORMATION'); Memo1.Lines.Add('Codec: ' + Acodec); Memo1.Lines.Add('Bitrate: ' + Abitrate); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. If OpenDialog1.Execute then ReadAviInfo(OpenDialog1.FileName); End; End.

Взято из http://forum.sources.ru.

Автор: Rouse_

©Drkb::04293.

Информация о BMP-файлах.

Информация о BMP-файлах

Code: { This tip show, how to get the filesize, width, height, bitcount and color used. From a bitmap. Dieses Beispiel zeigt, wie man Dateigrosse, breite, hohe, Farbtiefe und Farbanzahl. Von einem Bitmap ausliest. } Procedure TForm1.Button1Click(Sender: TObject); Var. Fileheader: TBitmapfileheader; Infoheader: TBitmapinfoheader; S: TFilestream; Begin. S := TFileStream.Create('c:\YourBitmap.bmp', fmOpenRead); Try. S.Read(fileheader, SizeOf(fileheader)); S.Read(infoheader, SizeOf(infoheader)); Finally. S.Free; End; Listbox1.Items.Clear; Listbox1.Items.Add('Filesize: ' + IntToStr(fileheader.bfSize)); Listbox1.Items.Add('Width: ' + IntToStr(infoheader.biWidth)); Listbox1.Items.Add('Height: ' + IntToStr(infoheader.biHeight)); Listbox1.Items.Add('BitCount: ' + IntToStr(infoheader.biBitCount)); Listbox1.Items.Add('Used: ' + IntToStr(infoheader.biClrUsed)); End; { BitCount: 1 = black/white. 4 = 16 colors. 8 = 256 colors. }

©Drkb::03781.

Информация о TDataLink.

Автор: James Thorpe (CSA Australasia).

Искать текст в TListView.

Code: // Call FindCaption Method to search for a list view item labeled by the. // string specified as the Value parameter. // Syntax: Function FindCaption(StartIndex: Integer; Value: string; Partial, Inclusive, Wrap: Boolean): TListItem; // Example, Beispiel: Procedure TForm1.Button1Click(Sender: TObject); Var. LvItem: TListItem; Begin. LvItem := ListView1.FindCaption(0, // StartIndex: Integer; '99', // Search string: string; True, // Partial, True, // Inclusive. False); // Wrap : boolean; If lvItem <> nil then. Begin. ListView1.Selected := lvItem; LvItem.MakeVisible(True); ListView1.SetFocus; End; End; // To search for a list view subitem (also for items), use this function: { Search for text in a listview item. @Param lv is the listview, supposed to be in vaReport mode. @Param S is the text to search for. @Param column is the column index for the column to search , 0-based. @Returns the found listview item, or Nil if none was found. @Precondition lv nil, lv in report mode if column 0, S not empty. @Desc The search is case-insensitive and will only match on the. Complete column content. Use AnsiContainsText instead of AnsiCompareText. To match on a substring in the columns content. Created 14.10.2001 by P. Below. } Function FindListViewItem(lv: TListView; const S: string; column: Integer): TListItem; Var. I: Integer; Found: Boolean; Begin. Assert(Assigned(lv)); Assert((lv.viewstyle = vsReport) or (column = 0)); Assert(S <> ''); For i := 0 to lv.Items.Count - 1 do. Begin. Result := lv.Items[i]; If column = 0 then. Found := AnsiCompareText(Result.Caption, S) = 0. Else if column > 0 then. Found := AnsiCompareText(Result.SubItems[column - 1], S) = 0. Else. Found := False; If found then. Exit; End; // No hit if we get here. Result := nil; End; // Example call: Procedure TForm1.Button1Click(Sender: TObject); Var. LvItem: TListItem; Begin. // Search subitem[0] for text from edit1. // in der Spalte subitem[0] den Text aus Edit1 suchen. LvItem := FindListViewItem(ListView1, Edit1.Text, 1); // if found, then show the item. // falls item gefunden, dann anzeigen. If lvItem <> nil then. Begin. ListView1.Selected := lvItem; LvItem.MakeVisible(True); ListView1.SetFocus; End; End; // Function to search items and select if found. Procedure LV_FindAndSelectItems(lv: TListView; const S: string; column: Integer); Var. I: Integer; Found: Boolean; LvItem: TListItem; Begin. Assert(Assigned(lv)); Assert((lv.ViewStyle = vsReport) or (column = 0)); Assert(S <> ''); For i := 0 to lv.Items.Count - 1 do. Begin. LvItem := lv.Items[i]; If column = 0 then. Found := AnsiCompareText(lvItem.Caption, S) = 0. Else if column > 0 then. Begin. If lvItem.SubItems.Count >= Column then. Found := AnsiCompareText(lvItem.SubItems[column - 1], S) = 0. Else. Found := False; End. Else. Found := False; If found then. Begin. Lv.Selected := lvItem; End; End; End; Procedure TForm1.Button1Click(Sender: TObject); Var. LvItem: TListItem; Begin. // in der Spalte subitem[0] den Text aus Edit1 suchen. LV_FindAndSelectItems(ListView1, Edit1.Text, 1); ListView1.SetFocus; End;

Числовой формат ячейки Excel.

Числовой формат ячейки

Данные в ячейках таблицы могут отображаться различным образом (число, дата, время, строка), способ отображения данных называется числовым форматом. Значение числового формата ячейки хранится в свойстве NumberFormat объекта Range, имеет тип строка и может содержать, например, такие значения: 'General', 'hh:mm:ss', '0,000'. Они соответствуют общему формату, формату времени и формату числа с тремя знаками после запятой. Опытным путем можно получить значения всех форматов, для этого в Delphi используем функцию GetFormatRange.

Code: Function GetFormatRange (sheet:variant; Range:string):string; Begin. Try. GetFormatRange:=E.ActiveWorkbook.Sheets.Item. [sheet].Range[range].NumberFormat; Except. GetFormatRange:=''; End; End;

Число текущей недели

Исправление загрузки RTF текста через поток

Автор: Лагонский Сергей Николаевич

Использование реестра

Автор: Алексей Федоров

Реестр - это центральное хранилище информации о параметрах системы и установленных программах. В версиях Windows до Windows 95 программисты сохраняли параметры программ либо в INI-файлах WIN.INI и SYSTEM.INI, либо в дополнительных INI-файлах. Хотя использование INI-файлов поддерживается и в Win32, Microsoft настоятельно рекомендует для хранения необходимых в работе программы параметров пользоваться реестром. Реестр представляет собой иерархическую базу данных, cостоящую из секций, подсекций и элементов. Каждая секция имеет свое назначение. Хранить данные о пользовательских программах Microsoft рекомендует в секции HKEY_CURRENT_USER и подсекции Software. В этой подсекции вы создаете подсекцию, идентифицирующую вашу программу или фирму, и уже внутри нее располагаете данные.

Модуль Registry.

Для упрощения работы с регистратором в состав Delphi (начиная с версии 2.0) входит модуль REGISTRY, содержащий реализацию трех классов, - TRegistry, TRegistryIniFile и TRegIniFile.

Внимание! Чтобы использовать свойства и методы классов TRegistry, TRegistryIniFile и TRegIniFile, необходимо включить в список uses модуль Registry.

TRegIniFile.

Собственно говоря, задача класса TRegIniFile - упростить перенос 16-битных программ в среду Windows 95. Методы этого класса эквивалентны методам класса TIniFile в 16-битной версии Delphi. Класс TRegIniFile позволяет обращаться к секции HKEY_CURRENT_USER, считывать и записывать строки (методы ReadString и WriteString), целочисленные значения (методы ReadInteger и WriteInteger), логические значения (методы ReadBool и WriteBool), секции (методы ReadSection, ReadSections и ReadSectionValues), удалять секции (метод EraseSection) и элементы (метод DeleteKey). Рассмотрим на примерах, как используются функции этого класса.

Microsoft рекомендует записывать данные, относящиеся к вашей программе, в подсекции секции HKEY_CURRENT_USER_Software. Предположим (не особенно фантазируя на эту тему), что ваша программа называется RegDemo, и данные для нее располагаются в секции Software\RegDemo. Ниже мы покажем, как поместить в регистратор строчные, целочисленные и логические данные, а затем считать их, - этих операций будет достаточно для того, чтобы сохранить в регистраторе параметры нашей программы, а затем считать их.

Прежде чем записать данные в определенную секцию, ее необходимо создать. Это происходит при вызове конструктора объекта TRegIniFile. В качестве параметра вы указываете название секции, и если таковой не существует, она создается:

RegFile := TRegIniFile.Create(SubKey);

После того как файл регистратора открыт (и создана определенная секция), мы можем записать данные. Поддерживаются три типа данных: целочисленные, логические и строчные данные. Для записи этих данных существуют методы WriteInteger, WriteBool и WriteString. В качестве параметров указываются:

· название подсекции;

· название элемента;

· записываемые данные.

Так, чтобы записать значение элемента MyIntVal в подсекции IntKey, следует выполнить код

RegFile.WriteInteger(IntKey, 'Int_Val', 32000);

а для того чтобы прочесть значение, необходимо вызвать метод ReadInteger (в качестве параметров указываются название подсекции, название элемента и значение по умолчанию):

RegFile.ReadInteger(IntKey, 'Int_Val', 0));

Для чтения логических и строчных данных используются соответственно методы ReadBool и ReadStr, а для их записи – методы WriteBool и WriteString.

Расссмотрим пример использования перечисленных выше методов класса TRegIniFile. Расположим в форме компонент Memo, две группы GroupBox и шесть кнопок – три в группе Write и три в группе Read. Нажатие каждой кнопки в группе Write приведет к записи соответствующего значения в реестр, нажатие каждой кнопки в группе Read – к чтению этого значения.

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

Code: Unit RDUnit; Interfaceuses. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Registry; Type. TForm1 = class(TForm). Memo1: TMemo; GroupBox1: TGroupBox; GroupBox2: TGroupBox; Label1: TLabel; Button1: TButton; Button2: TButton; Button3: TButton; Button4: TButton; Button5: TButton; Button6: TButton; Procedure FormCreate(Sender: TObject); Procedure Button1Click(Sender: TObject); Procedure Button2Click(Sender: TObject); Procedure Button3Click(Sender: TObject); Procedure Button4Click(Sender: TObject); Procedure Button5Click(Sender: TObject); Procedure Button6Click(Sender: TObject); Procedure FormClose(Sender: TObject; Var Action: TCloseAction); Private. { Private declarations }. Public. { Public declarations }. End; Var. Form1: TForm1; Implementation{$R *.DFM}var. RegFile: TRegIniFile; Const. //Подсекция. SubKey: string = 'Software\RegDemo'; // Элемент для хранения логических данных. BoolKey: string = 'BoolKey'; // Элемент для хранения целочисленных данных. IntKey: string = 'IntKey'; // Элемент для хранения строчных данных. StrKey: string = 'StrKey'; Procedure TForm1.FormCreate(Sender: TObject); Begin. // Создать экземпляр класса. RegFile := TRegIniFile.Create(SubKey); End; Procedure TForm1.Button1Click(Sender: TObject); Begin. // Записать целочисленное значение. RegFile.WriteInteger(IntKey, 'Value', 1998); End; Procedure TForm1.Button2Click(Sender: TObject); Begin. // Записать булево значение. RegFile.WriteBool(BoolKey, 'Value', True); End; Procedure TForm1.Button3Click(Sender: TObject); Begin. // Записать строку. RegFile.WriteString(StrKey, 'Value', 'Demo'); End; Procedure TForm1.Button4Click(Sender: TObject); Begin. // Считать целочисленное значение. Memo1.Lines.Add('Int Value = ' + IntToStr(RegFile.ReadInteger(IntKey, 'Value', 0))); End; Procedure TForm1.Button5Click(Sender: TObject); Begin. // Считать булево значение. If RegFile.ReadBool(BoolKey, 'Value', False) then. Memo1.Lines.Add('Bool Value = True'). Else. Memo1.Lines.Add('Bool Value = False'); End; Procedure TForm1.Button6Click(Sender: TObject); Begin. // Считать строку. Memo1.Lines.Add(RegFile.ReadString(StrKey, 'Value', '')); End; Procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); Begin. // Удалить секцию. RegFile.EraseSection(SubKey); // Освободить память. RegFile.Free; End; End.

Использование алгоритма расширяющегося префикса для кодирования и схожих пpоцессов

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

Алгоритмы сжатия могут повышать эффективность хранения и передачи данных посредством сокращения количества их избыточности. Алгоритм сжатия берет в качестве входа текст источника и производит соответствующий ему сжатый текст, когда как разворачивающий алгоритм имеет на входе сжатый текст и получает из него на выходе первоначальный текст источника (1). Большинство алгоритмов сжатия рассматривают исходный текст как набор строк, состоящих из букв алфавита исходного текста.

Избыточность в представлении строки S есть L(S) - H(S), где L(S) есть длина представления в битах, а H(S) - энтропия - мера содержания информации, также выраженная в битах. Алгоритмов, которые могли бы без потери информации сжать строку к меньшему числу бит, чем составляет ее энтропия, не существует. Если из исходного текста извлекать по одной букве некоторого случайного набоpа, использующего алфавит А, то энтропия находится по формуле:

--| 1.

H(S) = C(S) p(c) log ---- ,

C A p(c).

где C(S) есть количество букв в строке, p(c) есть статическая вероятность появления некоторой буквы C. Если для оценки p(c) использована частота появления каждой буквы c в строке S, то H(C) называется самоэнтропией строки S. В этой статье H (S) будет использоваться для обозначения самоэнтропии строки, взятой из статичного источника.

Модели, основанные на применении статичной вероятности, не позволяют хорошо характеризовать многие источники. Например, в английском тексте, буква U менее распространена чем E, поэтому модель статичной вероятности будет неправильно предсказывать, что QE должно быть более растространенным сочетанием, чем QU. Хорошо описывать такие источники позволяют вероятностные модели Маркова. Источники Маркова имеют множество состояний, смена которых происходит при появлении очередной буквы. Каждое состояние связывается с распределением вероятности, определяющим следующее состояние модели и следующую производимую букву. Когда марковский источник, представляющий собой текст, подобный английскому, выдает букву Q, он установливает состояние, в котором U есть более вероятный вывод. Дальнейшее изучение вопросов, связанных с энтропией, статичными источниками и источниками Маркова может быть продолжено в большинстве книг по теории информации [2].

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

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

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

Коды префиксов

Большинство широко изучаемых алгоритмов сжатия данных основаны на кодах Хаффмана. В коде Хаффмана каждая буква исходного текста представляется в архиве кодом переменной длины. Более частые буквы представляются короткими кодами, менее частые - длинными. Коды, используемые в сжатом тексте должны подчиняться свойствам префикса, а именно: код, использованный в сжатом тексте не может быть префиксом любого другого кода.

Коды префикса могут быть найдены посредством дерева, в котором каждый лист соответствует одной букве алфавита источника. Hа pисунке 1 показано дерево кода префикса для алфавита из 4 букв. Код префикса для буквы может быть прочитан при обходе деpева от корня к этой букве, где 0 соответствует выбору левой его ветви, а 1 - правой. Дерево кода Хаффмана есть дерево с выравненным весом, где каждый лист имеет вес, равный частоте встречаемости буквы в исходном тексте, а внутренние узлы своего веса не имеют. Дерево в примере будет оптимальным, если частоты букв A, B, C и D будут 0.125, 0.125, 0.25 и 0.5 соответственно.

0 0 0.

A ---------- o ---------- o ---------- o.

| | | A = 000.

|1 |1 |1 B = 001.

| | | C = 01.

B C D D = 1.

Рисунок 1: Дерево представления кода префикса

Обычные коды Хаффмана требуют предварительной информации о частоте встречаемости букв в исходном тексте, что ведет к необходимости его двойного просмотра - один для получения значений частот букв, другой для проведения самого сжатия. В последующем, значения этих частот нужно объединять с самим сжатым текстом, чтобы в дальнейшем сделать возможным его развертывание. Адаптивное сжатие выполняется за один шаг, т.к. код, используемый для каждой буквы исходного текста, основан на частотах всех остальных кpоме нее букв алфавита. Основы для эффективной реализации адаптивного кода Хаффмана были заложены Галлагером[3], Кнут опубликовал практическую версию такого алгоритма[5], а Уиттер его pазвил[10].

Оптимальный адаптированный код Уиттера всегда лежит в пределах одного бита на букву источника по отношению к оптимальному статичному коду Хаффмана, что обычно составляет несколько процентов от H . К тому же, статичные коды Хаффмана всегда лежат в пределах одного бита на букву исходного текста от H ( они достигают этот предел только когда для всех букв p(C) = 2 ). Такие же ограничения могут быть отнесены к источникам Маркова, если статичное или адаптированное дерево Хаффмана используется для каждого состояния источника, выведеного из его исходного текста. Существуют алгоритмы сжатия которые могут преодолевать эти ограничения. Алгоритм Зива-Лемпелла, например, присваивает слова из аpхива фиксированной длины строкам исходного текста пеpеменной длины[11], а арифметическое сжатие может использовать для кодирования букв источника даже доли бита[12].

Применение расширения к кодам префикса

Расширяющиеся деревья были впервые описаны в 1983 году[8] и более подpобно рассмотрены в 1985[9]. Первоначально они понимались как вид самосбалансиpованных деpевьев двоичного поиска, и было также показано, что они позволяют осуществить самую быструю реализацию приоритетных очередей[4]. Если узел расширяющегося дерева доступен, то оно является расширенным. Это значит, что доступный узел становится корнем, все узлы слева от него образуют новое левое поддерево, узлы справа - новое правое поддерево. Расширение достигается при обходе дерева от старого корня к целевому узлу и совершении пpи этом локальных изменений, поэтому цена расширения пропорциональна длине пройденного пути.

Тарьян и Слейтон[9] показали, что расширяющиеся деревья статично оптимальны. Другими словами, если коды доступных узлов взяты согласно статичному распределению вероятности, то скорости доступа к расширяющемуся дереву и статично сбалансированному, оптимизированному этим распределением, будут отличаться друг от друга на постоянный коэффициент, заметный при достаточно длинных сериях доступов. Поскольку дерево Хаффмана представляет собой пример статично сбалансированного дерева, то пpи использовании расширения для сжатия данных, pазмер сжатого текста будет лежать в пределах некоторого коэффициента от размера архива, полученного при использовании кода Хаффмана.

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

В случае зигзагообразного обхода лексикографического дерева, проведение как расширения, так и полурасширения усложняется, в отличие от прямого маршрута по левому или правому краю дерева к целевому узлу ( случаи зигзага рассмотрены в [8], [9] ). Этот простой случай показан на рисунке 2. Воздействие полурасширения на маршруте от корня ( узел w ) до листа узла A заключается в перемене местами каждой пары внутренних следующих друг за другом узлов, в результате чего длина пути от корня до узла-листа сокращается в 2 раза. В процессе полурасширения узлы каждой пары, более далекие от корня, включаются в новый путь ( узлы x и z ), а более близкие из него исключаются ( узлы w и y ).

0 0 0 0 . 0 0.

A --------o---------o--------o---------o . A --------o-----------o.

Z| y| x| w| . z| x|

|1 |1 |1 |1 . |1 |1.

| | | | . 0 | 0 |

B C D E . B --------o D -------o.

. y| w|

| . |1 |1.

||||||||> . | |

. C E.

Рисунок 2: Полурасширение вокруг самого левого листа дерева кодов

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

Hенужность поддержки лексикографического порядка значительно упрощает проведение операции полурасширения за счет исключения случая зигзага. Это может быть сделано проверкой узлов на пути от корня к целевому листу и переменой местами правых наследников с их братьями. Назовем это ПОВОРОТОМ дерева. Тепеpь новый код префикса для целевого листа будет состоять из одних нулей, поскольку он стал самым левым листом. На рисунке 3 дерево было повернуто вокруг листа C. Эта операция не нарушает никаких ограничений представления полурасширения. Доказательство этого просто выводится из потенциальной функции, приведенной в [9] для доказательства независимости ограничений представления от порядка следования поддеревьев узла.

0 0 . 0 0 0 0.

A ----------o----------o . C ----------o----------o----------o----------o.

X| w| . z| y| x| w|

|1 |1 . |1 |1 |1 |1.

0 | | . | | | |

B ----------o E . D B A E.

Y| =====>

|1 .

0 | .

C ----------o .

Z| .

|1 .

| .

D .

Рисунок 3: Поворот вокруг C исключает необходимость зигзагообразного полурасширения

Второе упрощение возникает, когда мы обнаруживаем, что можем по желанию менять между собой не только наследников одного узла, но и все внутренние узлы дерева кодов префиксов, поскольку они анонимны и не несут информации. Это позволяет заменить используемую в полурасширении операцию обоpота на операцию, требующую обмена только между двумя звеньями в цепи, которую будем называть ПОЛУОБОРОТОМ. Она показано на рисунке 4. Эта операция оказывает такое же влияние на длину пути от каждого листа до корня, как и полный обоpот, но уничтожает лексикографический порядок, выполняя в нашем примере отсечение и пересадку всего двух ветвей на дереве, в то время как полный обоpот осуществляет отсечение и пересадку 4 ветвей.

0 0 0 0.

A ------ -----o------------o C ------------o------------o.

X| w| x| w|

|1 |1 |1 |1.

| =====> | |

| | | |

| | | |

B C B A.

Рисунок 4: Полуобоpот вокруг A.

Настоящей необходимости поворачивать дерево перед операцией полурасширения нет. Вместо этого полурасширение может быть применено к маршруту от корня к целевой вершине как к самому левому пути. Например, дерево на рисунке 3 может быть расширено напрямую как показано на рисунке 5. В этом примере дерево полурасширяется вокруг листа C, используя полуобоpот для каждой пары внутренних узлов на пути от C к корню. Обратите внимание, что в результате этой перемены каждый лист располагается на одинаковом расстоянии от корня, как если бы деpево было сначала повернуто так, что C был самым левым листом, а затем полурасширено обычным путем. Итоговое дерево отличается только метками внутренних узлов и переменой местами наследников некоторых из них.

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

0 0 . 0 0.

A ----------o-----------o . A ----------o--------------o.

X| w| . x| w|

|1 |1 . |1 |1.

| . | |

0 | | . | 0 |

B ----------o E . E C ---------o.

Y| ===> y|

|1 . |1.

| . |

0 | . 0 |

C ----------o . B ---------o.

Z| . z|

. |1.

|1 . |

| . |

D . D.

Рисунок 5: Полурасширение вокруг C с использованием полуобоpота

Алгоритм расширяемого префикса

Представленная здесь программа написана по правилам языка Паскаль с выражениями, имеющими постоянное значение и подставляемыми в качестве констант для повышения читаемости программы. Структуры данных, используемые в примере, реализованы на основе массивов, даже если логическая структура могла быть более ясной при использовании записей и ссылок. Это соответствует форме представления из ранних работ по этой же тематике [5,10], а также позволяет осуществлять и простое решение в более старых, но широко используемых языках, таких как Фортран, и компактное представление указателей. Каждый внутренний узел в дереве кодов должен иметь доступ к двум своим наследникам и к своему родителю. Самый простой способ для этого - использовать для каждого узла 3 указателя: влево, вправо и вверх. Такое представление, обсуждаемое в [9] было реализовано только при помощи двух указателей на узел(2), но при этом компактное хранение их в памяти будет компенсировано возрастанием длительности выполнения программы и запутанностью ее кода. Нам потребуются следующие основные структуры данных:

Code: Const. Maxchar = ... { максимальный код символа исходного текста }; Succmax = maxchar + 1; Twicemax = 2 * maxchar + 1; Root = 1; Type. Codetype = 0..maxchar {кодовый интервал для символов исходного текста}; Bit = 0..1; Upindex = 1..maxchar; Downindex = 1..twicemax; Var. Left,right: array[upindex] of downindex; Up: array[downindex] of upindex;

Использование ассоциативных массивов

Использование встроенных функций.

Использование встроенных функций

Системные функции

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

Общий синтаксис вызова системных функций выглядит следующим образом:

Select название_функции(аргумент[ы]).

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

Например, чтобы найти идентификационный номер коллеги, зарегистрированного в системе как “harold”, следует выполнить оператор:

Select user_id(“harold”).

Если предположить, что идентификационный номер пользователя, работающего под именем “harold”, равен 13, то результат этого запроса будет выглядеть так:

---------------------

13.

(Выбрана 1 строка).

Вообще говоря, название системной функции говорит о том, информация какого типа будет возвращена.

Системная функция user_name (имя пользователя) использует в качестве аргумента идентификационный номер (ID) пользователя и возвращает имя пользователя:

Select user_name(13).

--------

Harold.

(Выбрана 1 строка).

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

Select user_name().

------------------

Dbo.

(Выбрана 1 строка).

Заметим, что системный администратор является владельцем любой базы данных, предполагая, что его серверный идентификатор ID равен 1. Пользователь-гость (guest) всегда получает серверный идентификатор, равный -1. Внутри базы данных значением функции user_name для владельца базы данных всегда является значение “dbo”, а его или ее пользовательский идентификатор (ID) равен 1. Внутри базы данных пользователь-гость всегда получает идентификатор 2.

Ниже приведен список названий системных функций, а также их аргументов и возвращаемых результатов:

Таблица 10-1: Системные функции, аргументы и результаты.

Название функции. Аргумент. Результат. Col_name. (object_id, column_id [, database_id]). Возвращает название столбца. Col_length. (название_объекта, Название_столбца). Возвращает указанную длину столбца. Действительную длину столбца можно узнать с помощью функции datalength. Curunreservedpgs. (dbid, lstart, Unreservedpgs). Возвращает количество свободных страниц на диске. Если база данных открыта, то это значение берется из памяти; если же база данных закрыта, то значение функции берется из столбца unreservedpgs таблицы sysusages. Data_pgs. (object_id, {doampg | ioampg}). Возвращает количество страниц, занимаемых таблицей (doampg) или индексами (ioampg). В результат не включаются страницы, которые используются для внутренних структур. Datalength. (выражение). Возвращает длину выражения в байтах. Выражением обычно является название столбца. Если выражение это символьная константа, то она должна быть заключена в кавычки. Db_id. ([название_базы_данных]). Возвращает идентификатор базы данных. Название базы данных должно быть символьным выражением; если же это константа, то она должна быть заключена в кавычки. Если же название базы данных вообще не указано, то функция db_id возвращает идентификатор текущей базы данных. Db_name. ([database_id]). Возвращает название базы данных. Аргумент database_id должен быть числовым выражением. Если же аргумент не указан, то функция db_name возвращает название текущей базы данных. Host_id. () Возвращает идентификатор текущего клиентского процесса на сервере. Host_name. () Возвращает название текущего клиентского процесса на сервере. Index_col. (object_name, index_id, key_# [, user_id]). Возвращает название индексированного столбца; если аргумент object_name не является названием таблицы или вьювера, то возвращается NULL. Isnull. (выражение1, Выражение2). Возвращается значение выражения2, если значение выражение1 равно NULL. Типы данных этих выражений должны неявно преобразовываться друг в друга, в противном случае нужно использовать функцию convert. Lct_admin. ({{ "lastchance" | "logfull" | "unsuspend" } , database_id} | "reserve", log_pages}). Эта функция управляет пороговым значением для числа повторных обращений к сегментам журнала транзакций (last-chance thresold). Аргумент lastchance задает пороговое значение для числа повторений в указанной базе данных. Аргумент logfull возвращает 1, если чило попыток превысило пороговое значение в указанной базе данных, и 0 в противном случае. Аргумент unsuspend разблокирует отложенные задания в указанной базе данных и обнуляет число повторений, если оно превысило пороговое значение. Аргумент reserve возвращает число свободных страниц журнала транзакций указанного размера, которые необходимы для успешного завершения транзакции. Object_id. (название_объекта). Возвращает идентификатор (ID) объекта. Object_name. (object_id[, database_id]). Возвращает название объекта. Proc_role. ("sa_role" | "sso_role" | "oper_role"). Проверяет, имеет ли пользователь, вызывающий процедуру, право на выполнение этой процедуры. Если такое право есть, то возвращается 1, иначе возвращается 0. Reserved_pgs. (object_id, {doampg | Ioampg}). Возвращает количество страниц, отведенных для таблицы или индекса. В результате этой функции учитываются страницы, предназначенные для внутренних структур. Rowcnt. (doampg). Возращает число строк в таблице. Show_role. () Возвращает текущий статус пользователя, если он есть в списке (sa_role, sso_role, oper_role). В противном случае возращается NULL. Suser_id. ([серверное_имя_пользователя]). Возвращает серверный идентификационный номер (ID) пользователя, взятый из таблицы syslogins. Если имя пользователя не указано, то возвращается серверный идентификатор (ID) текущего пользователя. Suser_name. ([server_user_id]). Возвращает серверное имя пользователя по указанному серверному идентификатору пользователя (ID), которые хранятся в таблице syslogins. Если аргумент (server_user_id) не указывается, то возвращается имя текущего пользователя. Used_pgs. (object_id, doampg, ioampg). Выводит общее число страниц, используемых для хранения таблицы и ее кластеризованного индекса. Tsequal. (timestamp,timestamp2). Сравнивает значения в столбце timestamp с указанным временем, чтобы не обновлять строку, кото-рая модифицируется в режиме просмотра (browsing). Аргумент timestamp указывает на время в просматриваемой строке, а timestamp2 в сохраняемой строке. Это позволяет использовать режим просмотра без вызова DB-Library. (См. “Режим просмотра”). User. Возвращает имя пользователя. User_id. ([имя_пользователя]). Возвращает идентификационный номер пользователя. Этот номер берется из таблицы sysusers текущей базы данных. Если имя пользователя не указывается, то возвращается идентификатор текущего пользователя. User_name. ([user_id]). Возвращает имя пользователя по его идентификтору в текущей базе данных. Если аргумент (user_id) не указывается, то возвращается имя текущего пользователя. Valid_name. (символьное_выражение). Возвращает 0, если символьное выражение является некоректным идентификатором (т.е. содержит недопустимые символы или его длина превышает 30 байтов), и ненулевое число, если аргумент является правильным идентификатором. Valid_user. (server_user_id). Возвращает 1, если указанный аргумент является правильным идентификатором пользователя, по крайней мере, одной базы данных SQL Сервера. Пользователь должен иметь права (уровень) sa_role или sso_role, чтобы вызывать эту функцию с аргументом, отличным от своего идентификатора.

Если аргумент системной функции является необязательным, то в качестве него подразумевается текущая база данных, сервер (host computer), текущий пользователь сервера или текущий пользователь базы данных. Во всех встроенных функциях (за исключением функции user) аргумент всегда заключается в скобки, даже если он является пустым.

Примеры использования системных функций

Функция col_length

В следующем запросе определяется длина столбца title из таблицы titles (выражение “х=“ указывается для того, чтобы результат запроса имел заголовок):

Select x = col_length("titles", "title").

X.

--------

80.

(Выбрана 1 строка).

Функция datalength

В отличие от функции col_length, которая находит длину столбца, определенную при создании таблицы, функция datalength показывает действительную длину (в байтах) всех данных, хранящихся в таблице. Эта функция полезна для данных типа varchar, nvarchar, varbinary, text и image, поскольку размер этих данных может изменяться. Функция datalength возвращает неопределенное значение NULL, если аргумент равен NULL. Для всех остальных типов данных, кроме перечисленных выше, функция datalength показывает длину, которая была указана при их определении. Ниже приведен пример, в которым находится длина данных из столбца pub_name таблицы publishers:

Select Length=datalength(pub_name), pub_name.

From publishers.

Length pub_name.

------- ------------------------

13 New Age Books.

16 Binnet & Hardley.

20 Algodata Infosystems.

(Выбрано 3 строки).

Функция isnull

Следующий запрос находит среднюю цену всех книг из таблицы titles, при этом заменяя неопределенные значения NULL в столбце price значением “$10.00”:

Select avg(isnull(price,$10.00)).

From titles.

------------

14.24.

(Выбрана 1 строка).

Функция user_name

В следующем запросе ищется строка из таблицы sysusers, в которой имя пользователя совпадает с результатом применения системной функции user_name к идентификатору пользователя, равному 1:

Select name.

From sysusers.

Where name = user_name(1).

Name.

------------------------

Dbo.

(Выбрана 1 строка).

Строковые функции

Строковые функции используются для выполнения различных операций над символьными строками и выражениями. Некоторые из строковых функций могут выполняться как с двоичными, так и с символьными данными. Можно также приписывать (соединять) двоичные данные к символьным строкам или выражениям.

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

Синтаксис строковых функций имеет следующий общий вид:

Select название_функции(аргументы).

Можно выполнить конкатенацию (приписывание) двоичных или символьных выражений следующим образом:

Select (выражение + выражение + [выражение]...).

При конкатенации несимвольных или недвоичных выражений нужно использовать функцию преобразования данных convert, как показано ниже:

Select "The price is " + convert(varchar(12),price).

From titles.

Большинство строковых функций выполняются только над данными типа char, nchar, varchar и nvarchar и над данными, которые неявно можно преобразовать в данные типа char и varchar. Однако некоторые строковые функции могут также выполняться над данными типа binary и varbinary. Функция patindex может выполняться над данными типа text, char, nchar, varchar, nvarchar.

Конкатенация может выполняться с данными типа binary или varbinary, а также char, nchar, varchar и nvarchar. Однако, конкатенация данных из столбцов типа text не разрешается.

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

В таблице 10-2 перечислены аргументы, которые используются в строковых функциях. Если функция имеет несколько аргументов одного типа, то они нумеруются по порядку char_expr1, char_expr2.

Таблица 10-2: Аргументы строковых функций.

Тип аргумента. Может быть заменен. Char_expr. Названием столбца, содержащим символьные данные, переменной или выражением типа char, varchar, nchar и nvarchar. Особо отмечается случай, когда в качестве выражения можно задавать текст (text). Символические константы должны быть заключены в кавычки. Expression. Названием столбца, содержащим двоичные или символьные данные, переменной или константой. Данные могут иметь тип char, varchar, nchar, nvarchar, как для аргумента char_expr, а также binary и varbinary. Pattern. Символьным выражением типа char, nchar, varchar, или nvarchar, которое кроме того может содержать символы замены, поддерживаемые SQL Сервером. Approx_numeric. Названием столбца, содержащим данные типа (float, real, double precision), переменной, константой или выражением. Integer_expr. Любым целым числом (типа tinyint, smallint или int), названием столбца, переменной или выражением целого типа. Максимальная величина числа отмечается в пояснении, если это необходимо. Start. Выражением вида integer_expr. Length. Выражением вида integer_expr.

Каждой строковой функции можно также задавать аргументы, которые неявно преобразуются к нужному типу. Например, функции, имеющие аргументы приближенного числового типа (approximate numeric), будут также работать и с аргументами целого типа. В этом случае SQL Сервер автоматически преобразует аргумент функции к нужному типу.

Таблица 10-3: Строковые функции, аргументы и результаты.

Функция. Аргумент. Результат. Ascii. (char_expr). Возвращает ASCII код первого символа в аргументе. Char. (integer_expr). Преобразует однобайтовое значение типа integer в значение типа character. Функция char обычно используется как обратная к функции ascii. Значение аргумента integer_expr должно находиться между 0 до 255. Результат будет иметь тип char. Если результирующее значение будет первым байтом многобайтового символа, то результат может быть не определен. Charindex. (expression1, expression2). В выражении expression2 проводится поиск первого вхождения выражения expression1 и возвращается номер позиции, с которой оно начинается. Если выражение expression1 не было найдено, то возвращается 0. Если же выражение expression1 содержит символы замены, то при выполнении функции charindex они рассматриваются как литералы. Char_length. (char_expr). Возвращает длину (число символов) в символьном выражении или тексте. Для данных, имеющих переменную длину, функция char_length не учитывает концевые пробелы. Длина выражений с многобайтовыми символами обычно меньше, чем число байтов, поэтому для определения числа байтов в этом случае следует использовать системную функцию datalength. Difference. (char_expr1, char_expr2). Возвращает целое число, являющееся разностью двух значений soundex. Функция soundex рассматривается ниже. Lower. (char_expr). Преобразует символы верхнего регистра в нижний. Результат имеет символьный тип. Ltrim. (char_expr). Удаляет пробелы в начале символьного выражения. Удаляются только те символы, которые эквивалентны пробелу в спецификации специальных символов SQL Сервера. Patindex. ("%pattern%", char_expr [using {bytes | chars | characters}] ). Возвращает номер позиции, с которой начинается первое вхождение строки pattern (образца) в указанное символьное выражение char_expr, и 0, если образец pattern не входит в нее. По умолчанию, функция patindex возвращает номер символа. Чтобы получить смещение в байтах для строк в многобайтовых алфавитах, необходимо указать опцию using bytes. Символ ‘%’ должен находиться до и после образца pattern, за исключением случаев, когда поиск происходит с начала или с конца строки. Об использовании символов замены в этой функции подробнее можно посмотреть в разделе “Символы замены” Справочного Руководства по SQL Серверу. Она может также использоваться для текстовых данных. Replicate. (char_expr, integer_expr). Возвращает строку того же типа, что и аргумент char_expr, состоящую из повторения выражения char_expr, указанное число раз, или столько раз, сколько умещается в 255 байтах, в зависимости от того, что меньше. Reverse. (char_expr). Возвращает символьное выражение char_expr в обратном порядке (перевернутым). Например, если char_expr это строка “abcd”, то обратной будет “dcba”. Right. (char_expr, integer_expr). Возвращает правую часть символьного выражения, начиная с указанного номера. Результат имеет тот же тип, что и символьное выражение. Rtrim. (char_expr). Удаляет концевые пробелы. Удаляются только те символы, которые эквивалентны пробелу в спецификации специальных символов SQL Сервера. Soundex. (char_expr). Возвращает четырехсимвольный код soundex заданной строки, который строится из последовательности одно и двухбайтовых латинских символов. Space. (integer_expr). Возвращает строку, состоящую из указанного числа однобайтовых пробелов. Str. (approx_numeric[, length [, decimal] ]). Возвращает символьное представление числа с плавающей точкой. Параметр length задает общее число возвращаемых символов (включая десятичную точку и все разряды слева и справа от нее), а параметр decimal задает число возвращаемых десятичных разрядов. Параметры length и decimal являются необязательными. Если они указываются, то они должны быть неотрицательными. По умолчанию, значение length равно 10, а decimal равно 0. Функция str округляет число таким образом, чтобы результат не превышал заданную длину length. Stuff. (char_expr1, start, length, char_expr2). Из строки char_expr1 удаляются символы, начиная с позиции, заданной параметром start. Число удаляемых символов определяется параметром length. После этого строка char_expr2 вставляется в строку char_expr1, начиная с позиции start. Чтобы просто удалить символы из строки, нужно задать строку char_expr2 равной NULL, но не пробелу “ “, который является обычным символом. Substring. (expression, start, length). Возвращает часть символьной или двоичной строки (подстроку). Параметр start указывает позицию первого символа подстроки, а параметр length определяет число символов в подстроке. Upper. (char_expr). Преобразует символы с нижнего регистра в верхний. Результат имеет символьный тип.

Примеры использования строковых функций

Функции charindex и patindex

Функции charindex и patindex возвращают начальную позицию строки-образца (pattern), которая задается пользователем. Обе функции имеют по два аргумента, но выполняются по разному. Функция patindex допускает использование символов замены в искомой строке, а функция charindex нет. Функцию charindex можно применять только к данным типа char, nchar, varchar и nvarchar, а функцию patindex, кроме вышеуказанных типов, можно применять к текстовым данным (text).

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

Следующий запрос демонстрирует использование этих функций для нахождения вхождения слова “wonderfull” в символьную строку, находящуюся в столбце notes таблицы titles:

Select charindex("wonderful", notes), patindex("%wonderful%", notes).

From titles.

Where title_id = "TC3218".

------------ -------------

46 46.

(Выбрана 1 строка).

Если не указывать строки, в которых нужно проводить поиск, то в результате будут указаны все строки таблицы, при этом для строк, не содержащих образца, будет выводиться нулевое значение 0. В следующем примере показано, как с помощью функции patindex находятся все строки в таблице sysobject, которые начинаются с символов “sys” и в которых четвертым символом является любой из символов a,b,c, или d:

Select name.

From sysobjects.

Where patindex("sys[a-d]%", name) > 0.

Name.

------------------------------

Sysalternates.

Sysattributes.

Syscharsets.

Syscolumns.

Syscomments.

Sysconfigures.

Sysconstraints.

Syscurconfigs.

Sysdatabases.

Sysdepends.

Sysdevices.

(Выбрано 11 строк).

Функция str

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

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

Например:

Select str(123.456, 2, 4).

--

**

(Выбрана 1 строка).

Данные короткого типа approx_numeric выравниваются вправо до указанной длины, а данные длинного типа approx_numeric укорачиваются до указанного числа десятичных разрядов.

Функция stuff

Функция stuff выполняет подстановку одной строки в другую. Эта функция удаляет указанное число символов из строки expr1, начиная с указанной позиции, а затем вставляет строку expr2 на это место вместо удаленных символов. Если в качестве начальной позиции или длины указано отрицательное число, то возвращается неопределенное значение NULL.

Если начальный номер превосходит длину строки expr1, то также возвращается неопределенное значение. Если же длина удаляемой подстроки превышает длину строки expr1, то удаляется вся часть слова вплоть до последнего символа. Например:

Select stuff("abc", 2, 3, "xyz").

----

Axyz.

(Выбрана 1 строка).

Для того, чтобы с помощью функции stuff удалить символы из строки, следует аргументу expr_2 присвоить неопределенное значение NULL, но не символ пробела в кавычках. Использование символа “ “ приведет к вставке пробела вместо удаленных символов. Например:

Select stuff("abcdef", 2, 3, null).

---

Aef.

(Выбрана 1 строка).

Select stuff("abcdef", 2, 3, " ").

----

A ef.

(Выбрана 1 строка).

Функции soundex и difference

Функция soundex преобразует символьную строку в четырехразрядный код, используемый при сравнении строк. Гласные буквы игнорируются при сравнении. Неалфавитные символы рассматриваются как терминаторы строки при вычислении функции soundex. Эта функция всегда возвращает некоторое значение. Следующие два имени имеют одинаковый код soundex:

Select soundex("smith"), soundex("smythe").

----- -----

S530 S530.

Функция difference (различие) производит сравнение кодов soundex двух строк и оценивает числом от 0 до 4 степень их сходства друг с другом. Значение 4 означает максимальное сходство. Например:

Select difference("smithers", "smothers").

---------

4.

Select difference("smothers", "brothers").

---------

2.

Большинство оставшихся строковых функций легки для понимания и использования. Например:

Таблица 10-4: Примеры строковых функций.

Оператор. Результат. Select right(“abcde”,3). Cde. Select right(“abcde”, 6). Abcde. Select upper(“torso”). TORSO. Select ascii(“ABC”). 65.

Функция substring

В следующем примере демонстируется применение функции substring. Здесь выбираются фамилии и инициалы каждого автора из таблицы authors, например, “Bennet A”.

Select au_lname, substring (au_f name, 1, 1).

From authors.

Функция substring (подстрока) действительно соответствует своему названию: ее результатом является часть символьной или двоичной строки.

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

Синтаксис функции substring имеет следующий вид:

Substring(выражение, начальная позиция, длина).

Например, в следующем операторе показано, как получить второй, третий и четвертый символы из строки “abcdef”:

Select x = substring("abcdef", 2, 3).

X.

---------

Bcd.

Конкатенация

С помощью операции конкатенации (+) можно приписывать (соединять) символьные или двоичные строки друг с другом.

Если соединяются между собой символьные строки, то их нужно заключать в одинарные или двойные кавычки.

Эта операция имеет следующий вид:

Select (выражение + выражение [+ выражение]...).

В следующем примере показано, как можно соединить две символьных строки:

Select ("abc" + "def").

-------

Abcdef.

(Выбрана 1 строка).

В следующем запросе выбираются фамилии и имена всех авторов, живущих в Калифорнии, причем фамилия отделяются от имени запятой и пробелом:

Select Moniker = (au_lname + ", " + au_fname).

From authors.

Where state = "CA".

Moniker.

-----------------------

White, Johnson.

Green, Marjorie.

Carson, Cheryl.

O'Leary, Michael.

Straight, Dick.

Bennet, Abraham.

Dull, Ann.

Gringlesby, Burt.

Locksley, Chastity.

Yokomoto, Akiko.

Stringer, Dirk.

MacFeather, Stearns.

Karsen, Livia.

Hunter, Sheryl.

McBadden, Heather.

(Выбрано 15 строк).

Для конкатенации числовых данных или данных типа даты необходимо использовать функцию преобразования типов convert:

Select "The due date is " + convert(varchar(30), pubdate).

From titles.

Where title_id = "BU1032".

---------------------------------------

The due date is Jun 12 1985 12:00AM.

(Выбрана 1 строка).

Конкатенация и пустая строка

При конкатенации пустая строка (“” или “) заменяется одним пробелом, например следующий оператор:

Select "abc" + "" + "def".

Выдаст следующий результат:

Abc def.

Композиция строковых функций

Строковые функции можно применять одну за другой, т.е. выполнять композицию (суперпозицию) функций. Например, следующий оператор выводит фамилию и инициалы каждого автора, причем после фамилии следует запятая, а инициалы заканчиваются точкой:

Select (au_lname + "," + " " + substring(au_fname, 1, 1) + ".").

From authors.

Where city = "Oakland".

----------------------

Green, M.

Straight, D.

Stringer, D.

MacFeather, S.

Karsen, L.

(Выбрано 5 строк).

Чтобы получить идентификатор издателя, за которым следуют два первых символа идентификатора книги, стоящей больше 20 долларов, можно воспользоваться следующим оператором:

Select substring(pub_id + title_id, 1, 6).

From titles.

Where price > $20.

--------------

1389PC.

0877PS.

0877TC.

(Выбрана 1 строка).

Текстовые функции

Встроенные текстовые функции используются для обработки текстовых (text) и графических (image) данных. Текстовые функции перечислены в следующей таблице.

Таблица 10-5: Встроенные текстовые функции.

Patindex. ("%pattern%", char_expr [using {bytes | chars | characters}] ). Возвращает номер позиции, с которой начинается первое вхождение строки pattern (образца) в указанное символьное выражение char_expr, и 0, если образец pattern не входит в нее. По умолчанию, функция patindex возвращает номер символа. Чтобы получить смещение в байтах для строк в многобайтовых алфавитах, необходимо указать опцию using bytes. Символ ‘%’ должен находиться до и после образца pattern, за исключением случаев, когда поиск происходит с начала или с конца строки. Об использовании символов замены в этой функции подробнее можно посмотреть в разделе “Символы замены” Справочного Руководства по SQL Серверу. Textptr. (название_столбца). Возвращает текстовый указатель, который является 16-ти байтовым адресом. Указатель должен указывать на первую текстовую страницу. Textvalid. (“название_таблицы.. название_столбца”, текстовый_указатель). Проводится проверка правильности тектового указателя. Отметим, что название столбца должно быть расширено названием таблицы. Возвращает 1, если указатель правильный, и 0, в противном случае. Set textsize. { n | 0}. Указывает ограничение на объем текстовых или графических данных в байтах, которые можно возвратить оператором select. Текущая установка хранится в глобальной переменной @@textsize. Параметр n определяет число возвращаемых байтов, а 0 устанавливает значение по умолчанию, равное 32К.

Кроме этих функций для текстовых данных можно использовать функцию datalength, которая была описана в разделе о системных функциях. Пользователь может также использовать глобальные переменные @@textcolid, @@textdbid, @@textobjid, @@textptr и @@textsize для обработки текстовых и графических данных.

Примеры использования текстовых функций

В следующем примере фунция textptr используется для локализации текстового поля blurb книги с идентификатором BU7832 в таблице texttest. Текстовый указатель, являющийся 16-ти байтовой двоичной строкой, хранится в текстовой переменной @val и передается как параметр команде readtext. Эта команда возвращает 5 байтов текста, начиная со второго байта со смещением в один байт.

Create table texttest.

(title_id varchar(6), blurb text null, pub_id char(4)).

Insert texttest values ("BU7832", "Straight Talk About Computers is an annotated.

Analysis of what computers can do for you: a no-hype guide for the critical user",

"1389").

Declare @val varbinary(16).

Select @val = textptr(blurb) from texttest where title_id = "BU7832".

Readtext texttest.blurb @val 1 5.

Фунция textptr возвращает 16-ти байтовый адрес. Целесообразно сохранить значение этого указателя в локальной переменной, как было показано, чтобы затем использовать его для ссылки на текстовое поле.

Еще один способ (альтенативный использованию фунции textptr) связан с глобальной переменной @@textptr и приведен в следующем примере:

Create table texttest.

(title_id varchar(6),blurb text null, pub_id char(4)).

Insert texttest values ("BU7832", "Straight Talk About Computers is an annotated.

Analysis of what computers can do for you: a no-hype guide for the critical user",

"1389").

Readtext texttest.blurb @@textptr 1 5.

Значение глобальной переменной @@textptr устанавливается при последнем по времени выполнении оператора вставки или обновления, который обращается к текстовому или графическому полю в текущем процессе SQL Сервера. Операторы модификации, выполняемые в других процессах, не влияют на эту переменную в текущем процессе.

Для преобразования текстовых данных в типы char, nchar, varchar или nvarchar, а также для преобразования графических данных в типы binary или varbinary, необходимо явно выполнить функцию преобразования типов convert, но при этом текстовые или графические данные укорачиваются до 255 байтов. Не допускается преобразование текстовых и графических данных в другие типы ни явно, ни неявно.

Математические функции

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

Вызов математических функций имеет следующий общий вид:

Название_функции(аргументы).

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

Таблица 10-6: Аргументы математических функций.

Тип аргумента. Может быть заменен на. Approx_numeric. Любое название табличного столбца приближенного числового типа (float, real, double precision), переменная, константа или выражение этого типа. Integer. Любое название табличного столбца целого типа (tinyint, smallint, int), переменная, константа или выражение этого типа. Numeric. Любое название табличного столбца приближенного числового (float, real, double precision), точного числового (numeric, dec, decimal, tinyint, smallint, int) или денежного (money) типа, переменная, константа или выражение этих типов или их комбинация. Power. Любое название табличного столбца приближенного числового, точного числового или денежного типа, переменная, константа или выражение этих типов или их комбинация.

Каждой функции можно также задавать аргументы, которые неявно преобразуются к нужному типу. Например, функции, имеющие аргументы приближенного числового типа (approximate numeric), будут также работать и с аргументами целого типа. В этом случае SQL Сервер автоматически преобразует аргумент функции к нужному типу.

Если функция имеет несколько аргументов одного типа, то они нумеруются по порядку (например, approx_numeric1, approx_numeric2).

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

Таблица 10-7:

Функция. Аргумент. Результат. Abs. (numeric). Возвращает абсолютную величину указанного выражения. Результат имеет тот же тип, точность и шкалу, что и аргумент. Acos. (approx_numeric). Возвращает значение угла (в радианах), косинус которого равен указанной величине. Asin. (approx_numeric). Возвращает значение угла (в радианах), синус которого равен указанной величине. Atan. (approx_numeric). Возвращает значение угла (в радианах), тангенс которого равен указанной величине. Atn2. (approx_numeric1, approx_numeric2). Возвращает значение угла (в радианах), тангенс которого равен частному от деления первого аргумента на второй. Ceiling. (numeric). Возвращает наименьшее целое число, большее или равное указанной величине. Результат имеет тот же тип, что и аргумент. Для аргументов типа numeric и decimal результат будет иметь ту же точность, что и аргумент, и нулевую шкалу. Cos. (approx_numeric). Возвращает значение тригонометрического косинуса указанного угла (заданного в радианах). Cot. (approx_numeric). Возвращает значение тригонометрического котангеса указанного угла (заданного в радианах). Degrees. (numeric). Преобразует радианы в градусы. Результат имеет тот же тип, что и аргумент. Для аргументов типа numeric и decimal результат будет иметь внутреннюю точность, равную 77 и шкалу, равную шкале аргумента. Когда аргумент имеет денежный тип, то внутреннее преобразование к типу float может привести к потере точности. Exp. (approx_numeric). Возвращает экспоненту указанной величины. Floor. (numeric). Возвращает целую часть числа (наибольшее целое число, меньшее или равное указанной величине). Результат имеет тот же тип, что и аргумент. Для аргументов типа numeric и decimal результат будет иметь ту же точность, что и аргумент, и нулевую шкалу. Log. (approx_numeric). Возвращает натуральный логарифм указанной величины. Log10. (approx_numeric). Возвращает десятичный логарифм указанной величины. Pi. () Возвращает константу пи, равную 3.1415926535897931. Power. (numeric, power). Возвращает значение степени, основанием которой является первый аргумент numeric, а показателем второй аргумент power. Для выражений типа numeric и decimal результат будет иметь внутреннюю точность, равную 77 и шкалу, равную шкале выражения. Radians. (numeric_expr). Преобразует градусы в радианы. Результат имеет тот же тип, что и аргумент. Для аргументов типа numeric и decimal результат будет иметь внутреннюю точность, равную 77 и шкалу, равную шкале аргумента. Когда аргумент имеет денежный тип, то внутреннее преобразование к типу float может привести к потере точности. Rand. ([integer]). Возвращает случайное число, заключенное между 0 и 1. Необязательный аргумент используется в качестве параметра. Round. (numeric, integer). Округляет первый аргумент numeric до указанного числа (integer) значящих цифр. Если второй аргумент положителен, то он определяет число знаков после десятичной точки. Если второй аргумент отрицателен, то он определяет число знаков до десятичной точки. Результат имеет тот же тип, что и первый аргумент и для выражений типа numeric и decimal будет иметь внутреннюю точность, равную 77, а шкалу, равную шкале этого выражения. Sign. (numeric). Возвращает знак аргумента, а именно возвращает +1, если он положителен, ноль, если он равен нулю (0) и -1, если он отрицателен. Результат имеет тот же тип и ту же точность и шкалу, что и аргумент. Sin. (approx_numeric). Возвращает значение тригонометрического синуса указанного угла (заданного в радианах). Sqrt. (approx_numeric). Возвращает значение квадратного корня указанной величины. Tan. (approx_numeric). Возвращает значение тригонометрического тангеса указанного угла (заданного в радианах).

Примеры использования математических функций

Встроенные математические функции работают с числовыми данными. Аргументы этих функций должны иметь целочисленный или приближенный тип. Многие функции выполняются с точными или приближенными числовыми значениями, или с данными денежного типа. Точность вычисления встроенных функций для данных типа float составляет по умолчанию 6 десятичных знаков.

При вычислении математических функций предусматривается реакция на возникновение ситуаций, связанных с ошибками в типах данных или выходом за указанный диапазон. Пользователь может установить опции arithabot или arithignore, чтобы определить вид ошибки, возникшей при вычислении функции. Более подробно об этих опциях будет рассказано в разделе “Ошибки преобразования”.

Ниже приведены простые примеры вычисления математических функций:

Функция. Результат. Select floor(123). 123. Select floor(123.45). 123.000000. Select floor(1.2345E2). 123.000000. Select floor(-123.45). -124.000000. Select floor(-1.2345E2). -124.000000. Select floor($123.45). 123.00. Select ceiling(123.45). 124.000000. Select ceiling(-123.45). -123.000000. Select ceiling(1.2345E2). 124.000000. Select ceiling(-1.2345E2). -123.000000. Select ceiling($123.45). 124.00. Select round(123.4545, 2). 123.4500. Select round(123.45, -2). 100.00. Select round(1.2345E2, 2). 123.450000. Select round(1.2345E2, -2). 100.000000.

Функция round(numeric,integer) всегда возвращает некоторую величину. Если второй аргумент (integer) отрицателен и по величине превосходит число значащих цифр в первом аргументе (numeric), то SQL Сервер округляет только старший разряд. Например следующий оператор:

Select round(55.55, -3).

Возвращает число 100.000000. (Число разрядов после десятичной точки равно шкале первого аргумента numeric.).

Календарные функции

Встроенные календарные функции используются для получения информации о датах и времени. Они выполняют арифметические операции над данными типа datatime и smalldatetime.

Каледарные функции можно использовать в списке выбора оператора select, в конструкции where, а также в любом месте, где допускаются выражения.

Данные типа datatime представляются в SQL Сервере двумя 4-х байтовыми целыми числами. Первые четыре байта предназначены для хранения числа дней перед или после базовой даты, которая для этой системы установлена на 1 января 1900 года. Тип данных datatime не допускает дат, предшествующих 1 января 1753. Вторые четыре байта внутреннего представления даты предназначены для хранения моментов времени с точностью до 1/3000 доли секунды.

Данные типа smalldatetime представляют даты и моменты времени с меньшей точностью чем данные типа datatime. Данные типа smalldatetime представляются двумя 2-х байтовыми целыми числами. В первых двух байтах хранится число дней после 1 января 1900 года. В следующих двух байтах хранится число минут, прошедших после полуночи до указанного момента времени. Таким образом, с помощью данных этого типа можно представлять даты из диапазона от 1 января 1900 года до 6 июня 2079 года с точностью до минуты.

Формат вывода дат, принимаемый по умолчанию, выглядит следующим образом:

Apr 15 1987 10:23PM.

В одном из последующих разделов этой главы, в котором рассматривается функция преобразования типов convert, будет дана информация об изменении форматов вывода даты для типов данных datatime и smalldatetime. Когда вводятся данные этих типов, их следует заключать в простые или двойные кавычки. SQL Сервер распознает большое число форматов для данных типа даты и времени. Дополнительную информацию о данных типа datatime и smalldatetime можно посмотреть в главе 7 “Создание баз данных и таблиц” и главе 8 “Добавление, изменение и удаление данных”.

В следующей таблице приведены календарные функции и их результаты.

Таблица 10-9: Календарные функции.

Функция. Аргумент. Результат. Getdate. () Текущая дата и время. Datename. (datepart,date). Возвращает указанную часть значения типа datatime и smalldatetime как строку символов (ASCII строку). Datepart. (datepart,date). Возвращает указанную часть значения типа datatime и smalldatetime, например, месяц, день или час, как целое число. Datediff. (datepart,date, date). Количество времени между первой и второй датами, выраженное в месяцах, днях или часах. Dateadd. (datepart,number,date). Дата, полученная из указанной даты добавлением указанного временного интервала.

Функции datename, datepart и dateadd получают в качестве аргумента часть даты, т.е. год, месяц, час и т.д. В следующей таблицы перечислены части даты, их сокращения (если оно есть) и возможные целочисленные значения для этой части. Функция datename выдает строку символов там, где это имеет смысл, например, для названия дней недели.

Таблица 10-10: Части даты.

Часть даты. Сокращение. Интервал значений. Year. Yy. 1753-9999. Quarter. Qq. 1 - 4. Month. Mm. 1 - 12. Week. Wk. 1 - 366. Day. Dd. 1 - 31. Dayofyear. Dy. 1 - 54. Weekday. Dw. 1 - 7 (Воскресенье 1 день для us_english). Hour. Hh. 0 - 23. Minute. Mi. 0 - 59. Second. Ss. 0 - 59. Millisecond. Ms. 0 - 999.

Заметим, что названия дней недели могут зависеть от установленного языка (language setting).

Получение текущей даты: getdate

Функция getdate возвращает текущую дату и время во внутреннем формате SQL Сервера, который используется данных типа datatime и smalldatetime. Эта функция не имеет аргументов, поэтому при ее вызове нужно указать только скобки ().

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

Select getdate().

--------------------------

Jul 29 1991 2:50 PM.

(Выбрана 1 строка).

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

Получение частей даты в виде числа или строки

Функции datepart и datename возвращают указанную часть даты, т.е. год, квартал, день, час и т.д., либо в виде числа, либо в виде строки символов. Поскольку данные типа smalldatetime представляют время только с точностью до минут, то, когда в качестве аргумента этих функций используются данные этого типа, количество секунд и миллисекунд всегда равно нулю.

В следующих примерах предполагается, что текущей датой является 29 июля, как и в предыдущем примере.

Select datepart(month, getdate()).

--------------

7.

(Выбрана 1 строка).

Select datename(month, getdate()).

-------------

July.

(Выбрана 1 строка).

Вычисленные календарных интервалов

Функция datediff вычисляет промежуток времени между указанными второй и первой датами, другими словами она находит календарный интервал между двумя датами. Результатом будет целое число со знаком, являющееся разностью между указанными частями второй и первой даты (date2 - date1).

В следующем запросе используется дата, равная 30 ноября 1985 года, для подсчета числа дней между этой датой и датами публикации книг, находящимися в столбце pubdate:

Select newdate = datediff(day, pubdate, "Nov 30 1985").

From titles.

Для книги, опубликованной 21 октября 1985 года, в предыдущем запросе будет получено число 40, т.е. число дней между 21 октября и 30 ноября. В следующем запросе календарный интервал вычисляется в месяцах:

Select interval = datediff(month, pubdate, "Nov 30 1985").

From titles.

Этот запрос укажет интервал в 1 месяц для книг, опубликованных в октябре, и 5 месяцев для книг, опубликованных в июне. Если первый аргумент функции datediff является более поздней датой по сравнению со вторым, то результат будет отрицательным. Поскольку для двух книг в таблице titles по умолчанию в столбце pubdate была указана функция getdate, то для них в этом столбце будет указана дата создания базы данных pubs. По этой причине в предыдущих запросах для этих книг будут получены отрицательные результаты.

Если один или оба аргумента этой функции имеют тип smalldatetime, то в процессе ее выполнения они преобразуются к типу datetime, чтобы вычисление было более точным. Секунды и миллисекунды для этого типа автоматически устанавливаются равными нулю при вычислении временного интервала.

Добавление календарного интервала: dateadd

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

Select dateadd(day, 3, pubdate).

From titles.

-----------------------

Jun 15 1985 12:00AM.

Jun 12 1985 12:00AM.

Jul 3 1985 12:00AM.

Jun 25 1985 12:00AM.

Jun 12 1985 12:00AM.

Jun 21 1985 12:00AM.

Sep 11 1986 11:02AM.

Jul 3 1985 12:00AM.

Jun 15 1985 12:00AM.

Sep 11 1986 11:02AM.

Oct 24 1985 12:00AM.

Jun 18 1985 12:00AM.

Oct 8 1985 12:00AM.

Jun 15 1985 12:00AM.

Jun 15 1985 12:00AM.

Oct 24 1985 12:00AM.

Jun 15 1985 12:00AM.

Jun 15 1985 12:00AM.

(Выбрано 18 строк).

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

Функции преобразования типов данных

Функции преобразования типов данных, как следует из их названия, преобразуют типы выражений из одного типа в другой и переформатируют информацию о датах и времени. SQL Сервер автоматически выполняет некоторые преобразования типов. Это называется неявным (implicit) преобразованием. Например, если пользователь сравнивает выражение типа char с выражением типа datetime, или выражение типа smallint с выражением типа int, или выражения типа char, имеющие различную длину, то SQL Сервер автоматически преобразует эти типы друг к другу.

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

SQL Сервер имеет три функции преобразования типов: convert (преобразовать), inttohex (целое в 16-ричное), hextoint (16-ричное в целое). Эти функции можно использовать в списке выбора, в предложении where, и везде, где допускаются выражения.

SQL Сервер не допускает некоторых преобразований типов данных. Например, нельзя преобразовать тип smallint к типу datetime или наоборот. Попытка выполнения недопустимого преобразования приводит к сообщению об ошибке.

Допустимые преобразования

На рисунке 10-1 показаны преобразования типов данных, поддерживаемые SQL Сервером:

· Преобразования, помеченные буквой “I”, выполняются автоматически (неявно). Для них можно не указывать функции преобразования типа, хотя использование функции convert в этих случаях не является ошибкой;

· Преобразования, помеченные буквой “Е”, должны выполняться пользователем явным образом с помощью соответствующей функции преобразования типов;

· Преобразования, помеченные буквой “IЕ”, выполняются автоматически в том случае, если при преобразовании не теряется точность или шкала и установлена опция arithabort numeric_truncation, в противном случае эти преобразования нужно выполнить явно.

· Преобразования, помеченные буквой “U”, недопустимы и не поддерживаются SQL Сервером. Если пользователь попытается выполнить такое преобразование, то SQL Сервер выдаст сообщение об ошибке;

· Преобразования типа к самому себе, помещены символом “_”. В общем случае SQL Сервер допускает явное преобразование типа к самому себе, но такие преобразования не имют смысла.

Рис. 10-1: Явные, неявные и недопустимые преобразования типов данных.

Использование функции convert

Функция преобразования общего назначения convert предназначена для выполнения разнообразных преобразований типов данных и изменения форматов представления даты и времени. Она имеет следующий общий вид:

Convert(тип_данных, выражение [, стиль] ).

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

Select title, convert(char(5), total_sales).

From titles.

Where type = "trad_cook".

Title.

----------------------------------------------------------------- -------

Onions, Leeks, and Garlic: Cooking.

Secrets of the Mediterranean 125.

Fifty Years in Buckingham Palace.

Kitchens 15096.

Sushi, Anyone? 5405.

(Выбрано 3 строки).

В этом примере данные из столбца total_sales, имеющие тип int, преобразуются к типу char(5), чтобы их можно использовать при поиске по образцу с ключевым словом like:

Select title, total_sales.

From titles.

Where convert(char(5), total_sales) like "15%" and type = "trad_cook".

Title.

---------------------------------------------- --------

Fifty Years in Buckingham Palace.

Kitchens 15096.

(Выбрана 1 строка).

Некоторые типы данных имеют либо длину, либо точность и шкалу. Если длина не указана, то SQL Сервер по умолчанию устанавливает длину, равную 30 символам, для строковых и двоичных данных. Если не указана точность или шкала, то SQL Сервер по умолчанию устанавливает для них значения 18 и 0 соответственно.

Правила преобразования

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

Преобразование строковых данных к нестроковому типу

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

· Запятая или точка в данных целого типа;

· Запятая в данных денежного типа;

· Буквы в данных точного или приближенного числового типа или в строке битов;

· Неправильное название месяца в данных типа даты.

Преобразование одного строкового типа к другому

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

Текстовые данные (text) можно явно преобразовывать в типы char, nchar, varchar и nvarchar. Максимальная длина строковых типов данных составляет 255 байтов. Если длина строки не указана, то по умолчанию устанавливается длина, равная 30 байтам.

Преобразование чисел к строковому типу

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

Select convert(char(1), 12.34).

Insufficient result space for explicit conversion.

Of NUMERIC value '12.34' to a CHAR field.

(Недостаточно места для размещения числового.

Значения “12.34” в строковом поле).

Округление при преобразовании к денежному типу

Денежные типы данных money и smallmoney позволяют сохранять четыре знака после десятичной точки, но при выводе они округляются до сотых долей (0.01) денежной единицы. Когда данные преобразуются к денежному типу, то они округляются до четырех знаков в дробной части.

Значения, которые преобразуются из денежного типа, округляются таким же образом, если это возможно. Если денежное значение преобразуется к точному числовому типу с менее чем тремя знаками после точки, то оно округляется в соответствии со шкалой, определенной для этого типа. Например, значение $4.50 преобразуется в целое число следующим образом:

Select convert(int, $4.50).

-----------

4.

Предполагается, что значения, преобразуемые к денежному типу, измеряются в полных (основных) денежных единицах, т.е. в долларах, а не в центах. Например, если установлена языковая опция (опция страны) us_english (американский английский), то целое число 4 эквивалентно 4 долларам, а не 4 центам.

Преобразование дат и моментов времени

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

Когда значение типа datetime преобразуется к типу smalldatetime, то оно округляется до минут.

Преобразование числовых типов

Числовые значения можно преобразовывать из одного типа в другой. Если значение преобразуется к точному числовому типу и установленная для него точность и шкала являются недостаточными для размещения нового числа, то может появиться сообщение об ошибке. Пользователь может использовать опции arithabort и arithignore, чтобы подготовить реакцию на возникновение этой ситуации.

Замечание. Опции arithabort и arithignore были переопределены в версии 10.0 SQL Сервера. Если пользователь использует эти опции в своем приложении, то необходимо убедиться в том, что они соответствуют своему функциональному назначению.

Преобразование двоичных типов

Типы данных SQL Сервера binary и varbinary зависят от аппаратной платформы, т.е. от аппаратуры компьютера. На некоторых платформах первый байт, следующий за префиксом 0х, является старшим, а на других - младшим.

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

Перед тем как преобразовать двоичную строку в целое число, функция convert удаляет начальный префикс 0х. Если строка состоит из нечетного числа цифр, то впереди добавляется 0. Если строка слишком велика для целого типа, то функция convert укорачивает ее. Если значение слишком мало, то функция convert выравнивает его вправо и добавляет нули.

Предположим, что надо преобразовать строку 0хО0000100 в целое число. На некоторых платформах эта строка представляет число 1, на других число 256. В зависимости от того, на какой платформе выполняется функция convert, результат будет равен 1 или 256.

Преобразование шестнадцатиричных данных

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

Аргументами функции hextoint являются литералы или переменные, состоящие из цифр и букв от A до F (заглавных или строчных) с префиксом 0х или без него. Ниже приводятся примеры допустимых аргументов для функции hextoint:

Hextoint("0x00000100FFFFF").

Hextoint("0x00000100").

Hextoint("100").

Функция hextoint удаляет у них префикс 0х. Если строка состоит более чем из восьми цифр, то функция hextoint укорачивает ее. Если длина строки меньше восьми, то функция hextoint выравнивает ее вправо и добавляет впереди нули. Затем функция hextoint вычисляет эквивалентное целое число, которое не зависит от платформы. Для вышеуказанного значения всегда будет выдаваться число 256 независимо от платформы.

Функция inttohex преобразует целое число в шестнадцатиричную строку из 8 символов без префикса 0х. Функция inttohex также возвращает всегда одно и то же значение независимо от платформы.

Преобразование графических данных в тип binary и varbinary

Пользователь может использовать функцию convert для преобразования графических данных типа image в данные типа binary или varbinary. Ограничением здесь является длина строки для типа binary, которая должна быть не больше 255 байтов. Если длина не указывается, то по умолчанию устанавливается длина в 30 символов.

Ошибки преобразования

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

Арифметическое переполнение и деление на ноль

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

· При явном или неявном преобразовании точных числовых типов, когда указаны слишком маленькие значения для точности или шкалы;

· При явном или неявном преобразовании данных, когда результирующее значение не попадает в диапазон, отведенный для денежного или календарного типа;

· При преобразовании строк с длиной большей 4-х байтов с помощью функции hextoint.

Как ошибки переполнения, так и деление на ноль, рассматриваются как серьезные ошибки, даже если они возникли в процессе явного или неявного преобразования. В этом случае следует использовать опцию arithabort arith_overflow, чтобы указать SQL Серверу как обработать эту ошибку. По умолчанию опция arithabort arith_overflow является включенной, что вызывает откат всей транзакции или всего пакета, в котором произошла такая ошибка. Если выключить опцию arithabort arith_overflow, то SQL Сервер прервет лишь выполнение текущего оператора, в котором появилась ошибка, но продолжит процесс выполнения других операторов в транзакции или в пакете. Пользователь может использовать глобальную переменную @@error, чтобы проверить результаты ошибочного оператора.

Опция arithignore arith_overflow определяет должен ли SQL Сервер выводить сообщение об ошибке после появления таких ошибок. По умолчанию эта опция выключена, т.е. выводится предупреждающее сообщение об ошибке при делении на ноль или потере точности. Включив эту опцию, можно устранить предупреждающее сообщение после появления таких ошибок. Необязательное ключевое слово arith_overflow можно не указывать в этих опциях.

Ошибки при выборе шкалы

Если в процессе явного преобразования происходит переполнение шкалы, то результаты округляются без предупреждающего сообщения. Например, если пользователь явно преобразует один из типов float, numeric или decimal в целый тип, то SQL Сервер автоматически отбрасывает дробную часть числа.

В процессе неявного преобразования типов numeric или decimal переполнение шкалы вызывает сообщение об ошибке. В этом случае следует использовать опцию arithabort numeric_truncation, чтобы указать насколько серьезной нужно считать эту ошибку. По умолчанию опция arithabort numeric_truncation, включена, что вызывает прерывание ошибочного оператора, но разрешает дальнейшее выполнение других операторов в транзакции или пакете. Если эта опция выключена, то SQL Сервер автоматически округляет результат и продолжает обработку запроса.

Ошибки при выборе диапазона

Функция convert выдает сообщение об ошибке диапазона (области), когда аргумент этой функции не попадает в определенный для него диапазон. Это случается достаточно редко.

Преобразования между двоичными и целыми типами данных.

Данные типа binary и varbinary можно рассматривать как шестнадцатиричные числа, состоящие из префикса 0х, за которым следует строка из цифр и букв. Эти числа интерпретируются различным образом на различных платформах. Например, строка 0хО000100 представляет число 65536 на платформах, у которых нулевой байт является самым старшим, и число 256 на платформах, у которых нулевой байт является самым младшим.

Функция convert и неявные преобразования.

Данные двоичного типа могут преобразовываться в целые числа как явно с использованием функции convert, так и неявно. При этом от двоичного значения отбрасывается префикс 0х, затем добавляются слева нули, если оно слишком короткое, или отбрасываются лишняя часть, если оно слишком длинное.

Как явное, так и неявное преобразование двоичных типов зависит от платформы. По этой причине результат преобразования может быть различным на различных платформах. Чтобы сделать эти результаты независимыми от платформы, следует использовать функцию hextoint при преобразовании 16-ричных строк в целые числа и функцию inttohex при обратном преобразовании.

Функция hextoint.

Функция hextoint выполняет независимое от платформы преобразование 16-ричных строк в целые числа. Эта функция получает в качестве аргумента правильную 16-ричную строку с префиксом 0х или без него, заключенную в скобки, или название переменной, или название столбца строкового типа.

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

Функция inttohex.

Функция inttohex выполняет независимое от платформы преобразование целых чисел в 16-ричные строки. Аргументом этой функции может быть любое выражение, имеющее целочисленное значение. Эта функция всегда возвращает одну и ту же эквивалентную заданному аргументу 16-ричную строку независимо от платформы.

Преобразование графических данных в двоичный вид.

Функция convert может использоваться для преобразования графических данных (image) в типы binary и varbinary. Единственным ограничением здесь является длина двоичных данных, которая должна быть не больше 255 байтов. Если длина двоичной строки не указывается, то по умолчанию она устанавливается равной 30 символам.

Преобразование других типов данных в битовый тип.

Точные и приближенные числовые типы могут преобразовываться к битовому типу неявно. Строковые типы нужно явно конвертировать в битовый тип с помощью функции convert.

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

Изменение форматов представления даты.

Параметр style (стиль) функции convert предоставляет возможность выбора большого числа форматов для представления данных типа datetime и smalldatetime, когда они преобразуются в типы char и varchar. Числовой аргумент этой функции указывает номер стиля и тем самым влияет на форму представления данных. Например, год в дате может представляться двумя или четырьмя цифрами. Чтобы год выводился в формате (yyyy), т.е. четырьмя цифрами с указанием столетия (века), нужно прибавить число 100 к значению параметра style.

В следующей таблице указаны возможные значения парметра style и связанные с этим значением форматы представления даты. Если этот параметр используется с данными типа smalldatetime, то в форматах, содержащих значения секунд и миллисекунд, будут выводиться нули на соответствующих местах.

Таблица 10-11: Значения стилевого параметра, определяющего формат даты.

Без века. (уу). С веком. (уууу). Стандарт. Выходной формат. - 0 или 100. По умолчанию. Мес дд гггг ча:ми AM (PM). 1. 101. США. Мм/дд/гг. 2. 2. SQL стандарт. Гг.мм.дд. 3. 103. Англия/Франция. Дд/мм/гг. 4. 104. Германия/Россия. Дд.мм.гг. 5. 105. Дд-мм-гг. 6. 106. Дд мес гг. 7. 107. Мес дд, гг. 8. 108. Ча:ми:се. - 109. По умолчанию + мс. Мес дд гггг ча:ми:мсе AM (PM). 10. 110. США. Мм-дд-гг. 11. 111. Япония. Гг/мм/дд. 12. 112. ISO. Ггммдд.

По умолчанию для стилевого параметра устанавливаются значения 0 или 100, а также 9 или 109, т.е. всегда указывается столетие (уууу) в дате.

В следующем примере показано, как используется параметр style в функции convert:

Select convert(char(12), getdate(), 3).

Этот оператор конвертирует текущую дату в строковый тип и представляет ее в соответствии с третьим форматом (style = 3), т.е. в виде дд/мм/гг.

©Drkb::02990.

Использование AutoInc полей в приложениях Midas.

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Использование AutoInc полей в приложениях Midas. При использовании полей AutoInc в клиентских приложениях. Наблюдается следующая ситуация: при вставке новых записей. В таблицу происходит исключение EkeyViolation. Данное. Исключение указывает на тот факт, что поле с типом данных. AutoInc автоматически в ClientDataSet не инкрементируется. По этой причине необходимо постоянно применять и обновлять. Данные, после каждой вставки. Т.е. использовать пару. CDS.ApplyUpdates()/CDS.Refresh. Этот прием вполне. Приемлем при локальном использовании и клиента и сервера, Но в сети сводит на нет все преимущества использования. DataSnap. И в таком случае клиент не сможет вставлять данные, Если у него нет соединения с сервером или ему (клиенту). Необходимо иметь постоянный доступ к серверу. Единственный выход из данной ситуации это самому генерировать. Значения для полей с типом AutoInc в клиентском приложении. А когда сервер будет обновлять данные, полеченные от клиента, То он не будет учитывать значения поля AutoInc при вставке. Да еще один важный момент касается уже существующих записей. Когда CDS обновит данные, чтобы нам не конфликтовать с уже. Существующими значениями, нужно генерировать отрицательные. Значения. Теперь при вставке нам нужно сгенерировать нужное. Значение. Второй код - еще одна возможность: это использование агрегатов. Зависимости: DB, DBClient, MConnect, SysUtils, Classes. Автор: Бушин Сергей, sanbotech@yandex.ru, Братск. Copyright: 1)Бушин Сергей, 2)Borland Corparation. Дата: 14 января 2003 г. ********************************************** } MyAutoIncValue: longint; … Procedure TmyModaule.ClientDSAfterInsert(DataSet: TDataSet); Begin. ClientDS.MyAutoIncField.AsInteger:=MyAutoIncValue; //генерируем новое значение. Dec(MyAutoIncValue); End; Procedure TMyModule.ClientDSAfterRefresh(DataSet: TDataSet); Begin. //Сбрасываем значение счетчика. MyAutoIncValue:=-1; End; ... //вторая возможность - использование агрегатов. Var. NewID: Integer; Begin. With ClientDataSet do. Begin. //вначале отключаем и очищаем агрегаты. AggregatesActive := False; Aggregates.Clear; //Теперь добавляем. With Aggregates.Add do. Begin. //здаем ему выражение. Expression := 'Max(AField)'; //имя. AggregateName := 'Runtime'; //активизируем его. Active := True; End; //подключаем агрегаты. AggregatesActive := True; Try. //Теперь генерируем наше новое значение. NewID := Aggregates[0].Value; // ...или еще одна альтернатива. // NewID := Aggregates.Find('Runtime').Value; Inc(NewID); Except. On E: Exception do SomeHandle; End; //вставляем и присваиваем. Insert; FieldByName('AField').AsInteger := NewID; End;

Использование записей для хранения информации полей

Code: { You sometimes wish to store multiple information in a given class like. In the example: alltogether when it belongs together. Thus accessing this information from out of the class can be achieved. Using property declaration. Its a good way to "clean your code" and. Make it as "logic" as possible. You also may have to store or load information from your class using. File or stream technology. This can be done at once for the recorded. Information from within the given class. } Type. TPersonRecord = Record. FirstName: String; LastName: String; BirthDate: TDate; End; TForm4 = class(TForm). Button1: TButton; Procedure Button1Click(Sender: TObject); Private. FActualUser: TPersonRecord; ... Procedure SaveActualUser(S: TFileStream); // it's an example. Procedure LoadActualUser(S: TFileStream); ... Public. Property FirstName: string read fActualUser.FirstName. Write fActualUser.FirstName; Property LastName : string read fActualUser.LastName. Write fActualUser.LastName; Property BirthDate: TDate read fActualUser.BirthDate. Write fActualUser.BirthDate; End; Procedure TForm4.SaveActualUser(S: TFileStream); Begin. // All that stuff at once in your Stream. S.Write(fActualUser, SizeOf(fActualUser)). End; Procedure TForm4.LoadActualUser(S: TFileStream); Begin. // All that stuff at once back in your class. S.Read(fActualUser, SizeOf(fActualUser)); End;

Использование Case.

Оператор выбора Case работает немного по другому чем в классических языках. В классических языках Case выбирает какой оператор запускать, а в T-SQL он выбирает выражение которое надо использовать для вычисления чего-то. Case выступает в ввиде функции которая возвращает результат в зависимости от условия. Имеет 2 формы написания:

Использование DB Controls без базы данных

Область применения

Довольно часто на различных форумах задаются вопросы примерно такого характера: “Как мне красиво (как в DBGrid) отобразить содержимое списка структур?”, “Как можно вывести данные в DBGrid/DBControlGrid?”.

Конечно, существуют различные варианты ответа на каждый из этих вопросов. В первом случае можно попытаться создать потомка TDBGrid. Во втором – создать потомка TDataSource. Однако на мой взгляд, предпочтительнее (как в отношении предоставляемого программисту набора функций, так и в отношении применимости конкретного ответа для решения целого круга похожих задач) способ, применяемый обычно для разрешения более принципиальной задачи: как обеспечить единообразную работу с данными из имеющейся БД (DBase, Interbase, MS SQL Server и т.п.), и с другими, в частности, локальными данными программы?

Работа с базами данных при помощи стандартного набора компонентов Delphi строится по следующей схеме:

Рисунок 1. Схема взаимодействия программы и элементов управления с БД.

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

Создание своего TDataSet – вовсе не такая сложная работа, как кажется на первый взгляд при просмотре исходного кода TDataSet и/или его стандартных потомков (например, TIBCustomDataSet). Основным препятствием является почти полное отсутствие документации от Borland. В поставляемом с Delphi простом примере TTextDataSet (потомка TDataSet, работающего с текстовым файлом на диске) прямо говорится: “Currently, the notes in this source file represent the only documentation on how to create a TDataSet implantation”, что в приблизительном переводе означает: “в настоящее время данный пример представляет собой единственную документацию по созданию реализации TDataSet”.

В данной работе я рассмотрю создание двух TDataSet. Один будет обеспечивать доступ в режиме “только чтение” к данным, вычисляемым “на лету” (в качестве примера выбрана таблица квадратов натуральных чисел от 1 до 20). Второй же позволит осуществлять доступ с возможностью модификации к списку структур вида (имя, адрес электронной почты). Любой промежуточный уровень функциональности легко может быть получен путем усечения функциональности второго примера.

В настоящей работе не рассматриваются:

· реализация установки фильтров на записи и поиска записей. Впрочем, получить представление о том, как это следует делать, можно, просмотрев исходные тексты методов FindRecord, FindFirst, FindNext, FindLast, FindPrior, Locate и Lookup (модули DB.PAS и DBTABLES.PAS, классы TDataSet и TBDEDataSet );

· поля-агрегаты (методы GetAggregateValue, GetAggRecordCount, ResetAggField);

· реализация интерфейса IProviderSupport (семейство методов PSxxxxx).

Простейший DataSet

Есть такое хорошее правило – прежде чем переходить к программированию, четко определить круг задач, которые обязательно должны быть решены. Давайте ему последуем. Я хочу создать потомка TDataSet, работающего с набором данных, содержащим два столбца: целое число и его квадрат. Для простоты этот набор данных будет содержать лишь 20 записей – для чисел от 1 до 20. Borland выдвигает еще одно требование: каждый потомок TDataSet должен поддерживать работу с закладками. Однако я позволю себе пока его проигнорировать – тем более, что и без этого получается практически вполне работоспособный класс. Желающие могут добавить в этот пример поддержку закладок, предварительно ознакомившись с механизмом закладок в следующем разделе.

ПРИМЕЧАНИЕ

О терминологии: в дальнейшем я буду использовать название TDataSet для обозначения программного кода и классов, тогда как под набором данных буду понимать сам набор данных, доступ к которому обеспечивает конкретный потомок TDataSet.

Чтобы создать потомка TDataSet, нужно понять, как TDataSet выполняет доступ к данным. Общедоступный (public) интерфейс полностью реализуется средствами самого TDataSet; на плечи конкретных потомков ложится лишь обеспечение средств коммуникации общедоступных методов с набором данных. В основном, коммуникация осуществляется методами InternalXXX, часть из которых в TDataSet объявлена пустыми, а часть – и вовсе абстрактными.

Эти методы можно разделить по их назначению на три группы: навигация (перемещение) по набору и чтение записи из БД в кэш-буфер (а также запись из кэш-буфера в набор данных), вставка/удаление записей, чтение/изменение значений полей записи, прочие методы (открытие и закрытие TDataSet, закладки, выделение и освобождение памяти).

Логика TDataSet никогда не работает со значениями полей записи прямо в наборе. Вместо этого вызовы GetRecord читают целиком записи, причем каждая из них заносится в свой кэш-буфер, и дальнейшие операции с полями каждой считанной записи выполняются в кэш-буфере. В TDataSet одновременно в памяти присутствуют, в общем случае, несколько буферов (свойство-массив Buffers). Помимо данных, считанных из БД, потомок TDataSet может размещать в буфере произвольную дополнительную служебную информацию.

Прежде, чем переходить к рассмотрению методов, я поясню одно из центральных для TDataSet понятий - понятие курсора.

Стандартный способ работы с БД таков, что целевая запись для таких воздействий, как удаление записи, изменение записи, вставка новой записи перед данной и т.п. не указывается явно при вызове соответствующей операции, а определяется предыдущими операциями. Соответственно, для хранения описания того места в наборе данных, которое будет являться целевым для следующей операции, необходимо ввести некую сущность – курсор.

Курсор - это произвольная информация, придающая смысл в каждый момент времени таким понятиям, как “текущая”, “следующая” и (для двунаправленных наборов данных) “предыдущая” запись. Позволю себе вольность пользоваться в отношении курсора фразой “перемещение курсора к некоторой записи”, подразумевая изменение составляющей курсор информации так, чтобы курсор указывал на эту запись.

Тот курсор, который определяет целевую позицию для действий, запрашиваемых у TDataSet сторонним кодом, я в дальнейшем буду называть логическим курсором. С логическим курсором в TDataSet связан буфер активной записи (свойство ActiveBuffer хранит адрес этого буфера).

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

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

ПРИМЕЧАНИЕ

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

Для поддержания согласованности логического курсора с физическим используется следующая техника: после вызова метода, от которого ожидается перемещение физического курсора на непредсказуемое расстояние от его текущего положение (например, при переходе на первую запись или поиске по закладке), вызывается метод Resync, считывающий в кэш-буферы запись, на которую теперь указывает физический курсор, а также несколько окружающих ее записей. Если же перемещение предсказуемо (как в случае метода MoveBy, вызываемого из Prior и Next), то читается лишь часть окружающих записей. Понятно, что в случае, когда вообще не ожидается никаких перемещений, никакие записи и не перечитываются.

Если потомку требуется переместить физический курсор вопреки ожиданиям TDataSet, необходимо оповестить его об этом вызовом CursorPosChanged. Такое оповещение обрабатывается не сразу, и, говоря откровенно, меня до сих пор гложут сомнения, не надежнее ли сразу вызывать Resync (хотя в таком случае можно проиграть в скорости, если после этого Resync будет вызван повторно).

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

ПРИМЕЧАНИЕ

UpdateCursorPos работает с буфером текущей записи: для помещения физического курсора на ту же запись, на которую указывает логический, он вызывает InternalSetToRecord, указав в качестве аргумента (буфера записи, к которой нужно перейти) буфер текущей записи (ActiveBuffer).

Единственное обнаруженное мной исключение из этого правила – метод InternalInsert (вызывающийся при вставке записи), перед вызовом которого не выполняется UpdateCursorPos, из-за чего приходится искать способ переместить физический курсор на ту же запись, на которую указывает логический, при этом не пользуясь private-членами TDataSet). Подробнее об этом – в следующем разделе.

При открытии (инициализации) логического курсора (TDataSet.OpenCursor, вызывается при TDataSet.Active:=true и по выходу из режима дизайнера) вызывается метод InternalOpen. Он должен сформировать список определений полей FieldDefs и, если свойство DefaultFields равно True, создать на их базе список полей Fields. Он также должен связать поля из списка Fields с полями набора данных и установить физический курсор в позицию перед первой записью. Кроме того, если до начала манипулирования содержащимися в наборе данными нужно предпринять какие-либо действия (например, установить соединение с удаленным сервером), их также следует выполнить в этом методе.

InternalOpen может вызываться не только из OpenCursor. Запрос на формирование списка FieldDefs может поступить и отдельно: в этом случае вызывается метод InitFieldDefs, который может вызывать InternalInitFieldDefs (последний должен инициализировать FieldDefs).

Для проверки того, что логический курсор открыт (т.е. что набор готов предоставить доступ к своим данным), вызывается функция IsCursorOpen, возвращающая True или False. Ясно, что до выполнения Open она должна возвращать False, а после Open и до последующего Close – True.

Для закрытия набора данных (TDataSet.Close) вызывается метод InternalClose, назначение которого симметрично InternalOpen: если DefaultFields установлено в True, то уничтожить список полей Fields (в этом случае они были созданы самим потомком в ходе выполнения InternalOpen); также, в случае необходимости, выполнить такие действия, как разрыв соединения с сервером БД.

Для навигации (перемещения логического курсора) по набору применяются общедоступные методы First, Prior, Next и Last.

Метод First вызывает метод InternalFirst, который должен установить физический курсор на позицию перед первой записью в наборе. После этого First выполняет серию вызовов GetNextRecord (а те, в конечном счете, GetRecord) для чтения в кэш-буферы следующей (т.е. первой) записи набора и нескольких последующих записей. Затем при помощи вызова DataEvent генерируется уведомление об изменении данных в кэш-буферах.

Зачем нужно устанавливать курсор на позицию перед первой записью, а потом читать следующую запись? Почему бы просто не поместить курсор сразу на первую запись? Дело, возможно, в том, что если для позиционирования на первую запись необходимо переоткрытие набора (например, в однонаправленных наборах), то эта обязанность возлагается на InternalFirst. То есть для помещения курсора на первую запись InternalFirst должен был бы переоткрыть набор и выполнить переход к следующей записи. По-видимому, команда разработчиков Borland решила, что будет лучше, если все команды навигации по записям будут подаваться из находящегося в базовом классе TDataSet слоя абстрактной логики, а не из методов, отвечающих за конкретную реализацию доступа к данным (таких, как InternalFirst). Таким образом, работа IntrnalFirst должна в такой ситуации завершаться переоткрытием (а после этой операции курсор, как уже говорилось, находится перед первой записью).

Аналогично, InternalLast должен устанавливать физический курсор в позицию, находящуюся за последней записью БД (это уже, видимо, просто для единообразия).

Методы Prior и Next апеллируют к одному и тому же методу GetRecord. Последний многофункционален: он должен проверить, не выйдет ли позиция курсора при выполнении операции за пределы БД, изменить позицию физического курсора, считать из набора в буфер записи, переданный в качестве аргумента, данные записи, ставшей текущей, и (в зависимости от параметров вызова) в случае ошибки возбудить исключение.

Когда необходимо прочитать значение некоторого поля текущей записи, вызывается GetFieldData, в который передается ссылка на соответствующий нужному полю объект TField и адрес буфера, содержащего запись. GetFieldData – перегруженный метод, но фактическое извлечение значения поля из буфера записи в так называемом Native-формате (его мы рассмотрим далее) осуществляет лишь одна из его версий (остальные версии в конечном счете просто вызывают именно ее).

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

Для выделения памяти под новый буфер вызывается метод AllocRecordBuffer, для освобождения занятой под буфер памяти – FreeRecordBuffer. Надо заметить, что TDataSet может повторно использовать уже выделенный однажды буфер для хранения другой записи. Обработку вытеснения записи из буфера при таком повторном использовании можно поместить туда же, куда и действия по подготовке буфера перед помещением туда записи – в InitRecordBuffer. Этот метод вызывается перед каждым помещением в буфер какой-либо записи.

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

Метод InternalHandleException служит для обработки возможных исключений, возникающих при чтении объекта из потока. Насколько мне удалось понять из исходных текстов потомков TDataSet, предлагаемых Borland, хорошим тоном является такая его реализация: Application.HandleException(Self).

Метод IsSequenced должен возвращать True, если в наборе каждую запись можно однозначно сопоставить с ее порядковым номером (т.е. числом, показывающим, какой по счету окажется запись при последовательном переборе всех записей, начиная с первой).

Помимо этих методов, в работе с данными может участвовать еще несколько семейств методов, предназначенных для расширения возможностей TDataSet. Одно из них - работа с закладками - как я уже говорил, будет рассмотрено в следующем разделе. Поддержка остальных не является обязательной (см. также перечень не рассматриваемых здесь функций в конце раздела “Область применения”). Однако три из них стоит реализовать, иначе довольно некрасиво смотрится полоса прокрутки в DBGrid и подобных ему элементах управления, а клиенты теряют возможность простого позиционирования на запись по ее номеру.

· GetRecordCount должен возвращать общее число содержащихся в наборе записей.

· GetRecNo должен возвращать номер (начиная с 1) текущей записи.

· SetRecNo должен устанавливать физический и логический курсоры на запись с указанным номером.

Последние два метода фактически являются реализацией свойства RecNo.

Два слова о Native-формате данных: детально мы его обсудим в следующем разделе, пока же – основное. Извлеченные из записи данные следует возвращать в особом формате (Native), своем для каждого типа поля. В нашем примере используются только поля типа ftInteger, для которых Native-формат представляет собой 4-байтовое целое число со знаком, т.е. значение типа integer. (см. чтение в методе GetFieldData).

Листинг 1 TMyDataSet (read-only).

Code: Unit DataSet0; //Простой Read-Only BiDirectional DataSet в виде таблицы. // квадратов целых чисел (два поля – число и его квадрат). Interface. Uses DB, Classes {для TComponent}; Type. TMyDataSet = class(TDataset). Protected. Procedure InternalHandleException; override; // Инициализация/деинициализация курсора. Procedure InternalInitFieldDefs; override; Procedure InternalOpen; override; Function IsCursorOpen: Boolean; override; Procedure InternalClose; override; // Выборка. Function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override; Function AllocRecordBuffer: PChar; override; Procedure FreeRecordBuffer(var Buffer: PChar); override; Procedure InternalInitRecord(Buffer: PChar); override; // Навигация. Procedure InternalFirst; override; Procedure InternalLast; override; Procedure InternalSetToRecord(Buffer: PChar); override; // Разрешение доступа. Function GetCanModify: Boolean; override; // Необязательные методы. Function GetRecordCount: Integer; override; //Везде в данном коде, где используется RecordCount, можно было бы просто. //написать List.Count. Реализовывать GetRecordCount не обязательно. Procedure SetRecNo(Value: Integer); override; Function GetRecNo: Integer; override; //Здесь номер записи считается от 1. Public. // Чтение поля. Function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override; // Создание/уничтожение. Constructor Create(AOwner: TComponent); override; Private. FIsOpen: boolean; FCursor: integer; End; TRecordData = record. //Собственно копия записи – по замыслу, она должна считываться из БД. Number, Square: integer; End; TRecordBuffer = record //Формат буфера, хранящего запись: данные записи + //служебная информация. RecordData: TRecordData; RecordIndex: integer; //Номер записи, считая от 1. End; PRecordBuffer = ^TRecordBuffer; Implementation. Procedure TMyDataSet.InternalHandleException; Begin. Application.HandleException(Self). End; Procedure TMyDataSet.InternalInitFieldDefs; Begin. FieldDefs.Clear; With FieldDefs.AddFieldDef do. Begin. DataType := ftInteger; FieldNo := 1; Name := 'Число'; End; With FieldDefs.AddFieldDef do. Begin. DataType := ftInteger; FieldNo := 2; Name := 'Квадрат'; End; End; Procedure TMyDataSet.InternalOpen; Begin. InternalInitFieldDefs; If DefaultFields then. CreateFields; BindFields(true); //Привязываем поля к БД. FIsOpen := true; FCursor := 0; End; Function TMyDataSet.IsCursorOpen: Boolean; Begin. Result := FIsOpen. End; Procedure TMyDataSet.InternalClose; Begin. BindFields(False); //Отвязываем поля. If DefaultFields then. DestroyFields; FIsOpen := false; End; Procedure TMyDataSet.InternalFirst; Begin. FCursor := 0. End; Procedure TMyDataSet.InternalLast; Begin. FCursor := RecordCount + 1. End; Function TMyDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; Begin. Result := grOK; Case GetMode of. GmPrior: if FCursor <= 1 then. Result := grBOF. Else. Dec(FCursor); GmNext: if FCursor >= RecordCount then. Result := grEOF. Else. Inc(FCursor); GmCurrent: if (FCursor < 1) or (FCursor > RecordCount) then. Result := grError; End; If result = grOK then. With PRecordBuffer(Buffer)^ do. Begin. RecordData.Number := FCursor; RecordData.Square := sqr(RecordData.Number); RecordIndex := FCursor; End; If (result = grError) and DoCheck then. DatabaseError('Error in GetRecord()'); End; Function TMyDataSet.GetRecordCount: Integer; Begin. Result := 20. End; Procedure TMyDataSet.SetRecNo(Value: Integer); Begin. If (Value < 1) or (Value >= RecordCount + 1) then. Exit; FCursor := Value; Resync([]). End; //Мне не пришло в голову более умного средства синхронизации логического. // курсора с физическим, чем выполнение Resync (ресинхронизация – сброс. // логического курсора и последующее чтение записей, окружающих. // физический курсор). Function TMyDataSet.GetRecNo: Integer; //Возвращает номер записи, соответствующей активному в данный момент буферу. Begin. Result := PRecordBuffer(ActiveBuffer)^.RecordIndex. End; Procedure TMyDataSet.InternalSetToRecord(Buffer: PChar); Begin. FCursor := PRecordBuffer(Buffer)^.RecordIndex. End; Function TMyDataSet.AllocRecordBuffer: PChar; Begin. GetMem(result, sizeof(TRecordBuffer)). End; Procedure TMyDataSet.FreeRecordBuffer(var Buffer: PChar); Begin. FreeMem(Buffer, sizeof(TRecordBuffer)). End; Procedure TMyDataSet.InternalInitRecord(Buffer: PChar); Begin. Inherited; //Нам не нужна какая-то особая инициализация буфера записи. // до чтения туда фактической записи. End; Function TMyDataSet.GetCanModify: Boolean; Begin. Result := false. End; Function TMyDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean; Begin. Result := true; Case Field.FieldNo of. 1: PInteger(Buffer)^ := PRecordBuffer(ActiveBuffer)^.RecordData.Number; 2: PInteger(Buffer)^ := PRecordBuffer(ActiveBuffer)^.RecordData.Square; Else. Result := false; End; End; Constructor TMyDataSet.Create(AOwner: TComponent); Begin. Inherited; FIsOpen := false; End; End. Для проверки работы класса TMyDataSet можно использовать следующий тестовый проект: Листинг 2. Program Dataset; Uses Forms, DB, DBGrids, DBCtrls, Controls, DataSet0; Var. F: TForm; DS: TDataSource; MyDataSet: TMyDataSet; Begin. Application.Initialize; Application.CreateForm(TForm, F); F.Width := 300; F.Height := 300; F.Position := poDesktopCenter; MyDataSet := TMyDataSet.Create(F); MyDataSet.Open; DS := TDataSource.Create(F); DS.DataSet := MyDataSet; With TDBNavigator.Create(F) do. Begin. Parent := F; Align := alTop; DataSource := DS. End; With TDBGrid.Create(F) do. Begin. Parent := F; Align := alClient; DataSource := DS. End; Application.Run; End.

Использование Debug API.

С чего все начиналось:

Использование DynArrayFromVariant.

Code: Procedure TForm1.Button1Click(Sender: TObject); Type. T2DIntArray = array of array of Integer; Var. DynArray: T2DIntArray; V: Variant; I, k: Integer; Begin. V := VarArrayCreate([0, 1, 0, 1], varInteger); V[0, 0] := 00; V[0, 1] := 01; V[1, 0] := 10; V[1, 1] := 11; DynArrayFromVariant(Pointer(Dynarray), V, TypeInfo(T2DIntArray)); For i := 0 to High(Dynarray) do. For k := 0 to High(Dynarray[i]) do. Memo1.Lines.add(IntToStr(DynArray[i, k])); End; { The problem with DynArrayFromVariant is that you can only use it on. Variant arrays with 0-based indexes, trying to use it on an array with 1. As lower bound blows up. Since the documentation is silent on that i. Would consider it a bug. }

Использование команды RDTSC процессора Pentium для работы с малыми временными интервалам

Автор: Шевченко В.В.

Использование компилятора Delphi (dcc32.exe) в прикладных программах

Введение. Технология.

Хотя в названии статьи тема выглядит довольно узко, я хотел бы рассказать не только об использовании dcc32, но и о технологии, которой я дал условное название "многозвенное программирование", хотя вынести это название в заголовок статьи мне показалось неправильным. Какой смысл я вкладываю в термин "многозвенное программирование"? Начну издалека. Работу над более или менее большими программами можно разделить на два крупных этапа. Первый этап - это собственно разработка, которая включает формулировку технического задания, увязку требований заказчика, проектную фазу, итеративное уточнение структуры проекта, программирование, отладку и тестирование. Первый этап заканчивается выпуском первой версии и началом эксплуатации программы у заказчика (или у массы пользователей, если программа была разработана по собственной инициативе для распространения или продажи). Затем наступает этап сопровождения, который включает устранение обнаруживаемых ошибок, адаптацию к постоянно изменяющимся требованиям заказчика, ввод дополнительных возможностей, которые не были оговорены в исходном задании. Часто бывает так - за время сопровождения программа претерпевает настолько существенные изменения, что сопровождение ее становится делом гораздо более трудоемким и хлопотным, чем разработка.

Если первый этап достаточно хорошо поддерживается разнообразным программистским инструментарием, то второй этап в этом смысле поддержан значительно хуже. Главной целью "многозвенного программирования" как раз и является поддержка этапа сопровождения. В чем основная идея этого подхода? Рассмотрим простую схему:

разработчик <---> заказчик

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

разработчик <---> технолог <---> пользователь

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

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

Эта идея используется многими разработчиками, но в литературе я не встречал ее обсуждения как инструмента для сопровождения. В этом смысле вместо термина "многозвенное программирование" обычно используется термин "проблемно-ориентированный язык".

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

Конечно, здесь есть и другая сторона медали - маркетинговые соображения. Если заказчик получит развиваемый инструмент, то разработчик может остаться в проигрыше. И чем лучше инструмент, тем менее вероятно, что заказчик будет оплачивать сопровождение программы. Здесь уже решать разработчику - или заниматься только сопровождением старых программ или высвобождать время для новых разработок.

Вопросы реализации.

Вот собственно то, что я хотел сказать о технологии "многозвенного программирования". Теперь практическая часть. Как можно реализовать такую технологию? Один из наиболее используемых вариантов - это встраивание в программу интерпретатора проблемно-ориентированного языка. Встраивание компилятора я встречал значительно реже. В своей программистской практике я использовал оба варианта. Достоинства интерпретатора очевидны, но также очевидны и недостатки. Общий принцип состоит в том, что интерпретатор либо каждый раз интерпретирует исходное представление программы на проблемно-ориентированном языке, либо порождает промежуточный код, исполняемый некоторой виртуальной машиной. Примеры - пакет Microsoft Office с языком VB for Applications, реализация языка Java. Сюда же относятся все скриптовые языки. Если требуется межплатформенная совместимость, то интерпретаторы, вероятно, будут лучшим вариантом. Если же более важны соображения эффективности, то компиляция оказывается более предпочтительным выбором. Общий принцип - берем описание задачи на проблемно-ориентированном языке, генерируем соответствующий код на некотором универсальном языке, компилируем его и выполняем.

В этом разделе статьи я расскажу о втором варианте - использование компилятора, а конкретно, dcc32.exe из поставки Delphi (хотя можно использовать любой другой быстрый и качественный компилятор для любого другого подходящего языка).

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

1. Генерация кода

На основе исходного представления, которое формулирует технолог, нужно сгенерировать код для компиляции. Исходное представление может быть любым, в простейшем случае - это обычный текст. В процессе генерации кода наибольшее внимание нужно уделить диагностике ошибок. То есть, ошибки желательно выявить во время генерации кода и генерировать уже синтаксически правильный код. Для этого можно использовать любые доступные методы, вплоть до синтаксических анализаторов с рекурсивным спуском - такие анализаторы достаточно просты и описаны во многих книгах, например у Бьерна Страуструпа в "Язык программирования C++" (Третье издание). Если есть возможность, то желательно контролировать также семантическую правильность. Далее я буду рассматривать только те моменты, которые являются общими для всех задач без учета их специфики.

Генерировать исходный текст можно любым способом, например, просто посылая строки текста в файл. Более удобный способ, как мне кажется, это направление текста в строко-ориентированный поток. Такой поток предоставляет дополнительное удобство при диагностике ошибок. Библиотека DccUsing содержит два потоковых класса: TFileCompileOut и TStringCompileOut, которые порождаются от TCompileOut. Классы очень просты, их реализацию можно посмотреть в исходном файле библиотеки, поэтому я дам только обзор. Базовый класс имеет методы:

Code: Public. Procedure IncLevel; Procedure DecLevel; Procedure AddSpace; Procedure AddLine(const aLine: String); Procedure AddLines(const aLines: array of String); Procedure AddFile(const aFileName: String); Procedure AddLineTemplate(const aLine: String; Const aArgs: array of String); Procedure AddLinesTemplate(const aLines, aArgs: array of String); Procedure AddFileTemplate(const aFileName: String; Const aArgs: array of String); Procedure AddPoint(aPoint: Integer); Function FindPoint(aLine: Integer): Integer; Property Level: Integer read FLevel; Property LinesCount: Integer read FLinesCount;

Использование Hints.

Aвтор: Serzs.

Использование многомерных массивов в процедурах и функциях из Math.pas.

Code: { **** UBPFD *********** by kladovka.net.ru **** >> Использование многомерных массивов в процедурах и функциях из Math.pas. Многим процедурам и функциям из Math.pas в качестве одного из параметров требуется одномерный открытый массив, например: Function Mean(const Data: array of Double): Extended; Function Sum(const Data: array of Double): Extended; Function MinValue(const Data: array of Double): Double; Function MaxValue(const Data: array of Double): Double; Эти процедуры и функции можно применить также для работы с многомерными массивами или подмассивами одномерного массива, приводя их тип и заменяя описание открытого массива на пару "Data: pointer; Bound: integer", где первый параметр - указатель на первый обрабатываемый элемент массива, второй - количество обрабатываемых элементов минус 1. Например, для доступа к функции MaxIntValue можно использовать тип: TMaxIntValue = function(Data: pointer; Bound: integer): integer; Зависимости: Math. Автор: Александр Шарахов, alsha@mailru.com, Москва. Copyright: Александр Шарахов. Дата: 18 января 2003 г. ********************************************** } Type // Тип для доступа к MaxIntValue. TMaxIntValue = function(Data: pointer; Bound: integer): integer;

Использование Microsoft ScriptControl.

Использование Microsoft ScriptControl.

Анатолий Тенцер

Содержание

Введение

Добавление TScriptControl в программу

Импорт ActiveX-сервера

Настройка свойств и вызов скриптов

Интеграция TScriptControl с VCL.

Модель расширения TScriptControl.

Интерфейс IDispatch.

Function GetIdsOfNames.

Function Invoke.

Информация RTTI Delphi.

Сводим воедино

Пишем GetIdsOfNames.

Пишем Invoke.

Оператор For Each.

Интерфейс IEnumVariant.

Класс TVCLEnumerator.

Компонент TVCLScriptControl.

Заключение

Введение

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

В то же время в Windows, как правило, уже имеется достаточно качественный интерпретатор, который может быть легко встроен в вашу программу. Речь идет о Microsoft ScriptControl. Он устанавливается вместе с Microsoft Internet Explorer, входит в Windows 2000 и Windows 98, а для младших версий доступен в виде свободно распространяемого отдельного дистрибутива, объем которого составляет около 200 Кбайт. Его можно получить по адресу http://msdn.microsoft.com/scripting или установить с нашего компакт-диска. В дистрибутив входят ActiveX-компонент и файл помощи с описанием его свойств и методов.

Добавление TScriptControl в программу

Импорт ActiveX-сервера

Чтобы добавить Microsoft ScriptControl на палитру компонентов Delphi, необходимо импортировать компонент ActiveX под названием Microsoft ScriptControl.

После этого на закладке ActiveX появится невизуальный компонент TScriptControl, который можно разместить на форме.

Настройка свойств и вызов скриптов

Рассмотрим ключевые свойства и методы TScriptControl.

Property Language: String.

Задает язык, интерпретатор которого будет реализовывать компонент. В стандартной поставке доступны VBScript и JScript, однако, если в вашей системе установлены расширения Windows Scripting, возможно использование других языков, таких как Perl или Rexx.

Property Timeout: Integer.

Задает интервал исполнения скрипта, по истечении которого генерируется ошибка. Значение –1 позволяет отключить ошибки, связанные с истечением отведенного времени (timeout), что позволит скрипту исполняться неограниченное время.

Property UseSafeSubset: Boolean.

При установке этого свойства в TRUE компонент может выполнять ограниченный набор действий, заданный текущими установками безопасности в системе. Это свойство полезно, если вы запускаете скрипты, полученные, например, через Интернет.

Procedure AddCode(const Code: WideString);

Добавляет код, заданный параметром к списку процедур компонента. В дальнейшем эти процедуры могут быть вызваны при помощи метода Run либо из других процедур скрипта.

ScriptControl1.AddCode(Memo1.Text);

Function Eval(const Expression: WideString): OleVariant.

Выполняет код, заданный в параметре Expression, и возвращает результат исполнения. Позволяет выполнить код без добавления его к списку процедур компонента.

Procedure AddObject(const Name: WideString; Object_: IDispatch; AddMembers: WordBool);

Добавляет объект к пространству имен компонента. Объект должен быть сервером автоматизации. Добавленный объект доступен как объект в коде скрипта. Например, если в программе создан сервер автоматизации External, реализующий метод DoSomething(Value: Integer), то, добавив объект

ScriptControl1.AddObject(‘External’, TExternal as IDispatch, FALSE);

мы можем в коде скрипта использовать его следующим образом:

Dim I.

I = 8 + External.DoSomething(8).

Function Run(const ProcedureName: WideString; var Parameters: PSafeArray): OleVariant;

Выполняет именованную процедуру из числа ранее добавленных при помощи метода AddCode. В массиве Parameters могут быть переданы параметры.

Procedure Reset;

Сбрасывает компонент в начальное состояние, удаляя все добавленные ранее объекты и код.

Таким образом, TScriptControl представляет собой достаточно гибкую исполняющую систему с возможностями расширения путем добавления в ее пространство имен серверов автоматизации.

Интеграция TScriptControl с VCL.

В существующем виде возможности TScriptControl сильно ограничены сложным доступом к классам VCL. Исполнение интерпретируемого кода – это хорошо, однако хотелось бы иметь возможность обращаться из него к компонентам в программе, получать и устанавливать их свойства, обрабатывать возникающие в них события, например, следующим образом:

Code: Sub Main(). Dim Control. Control = Self.Controls("Panel2"). Control.Add "Panel3", "TPanel". With Panel3. .Align = "alTop". .BevelOuter = "bvNone". .Height = 40. .Caption = "". .Add "Btn", "TButton", True. With Btn. .Top = 10. .Left = .Top. .Caption = "Click me". End With. End With. End Sub. Sub Btn_OnClick(). Dim StatusBar. Dim Panel. Dim I. I = 0. For Each Panel In StatusBar.Panels. I = I + 1. With Panel. .Text = .Text & " " & CStr(I). End With. Next. End Sub.

Использование Microsoft Transaction Server.

1. Зачем нужен Microsoft Transaction Server?

1.1. COM и распределенные вычисления

В предыдущей статье данного цикла были рассмотрены общие вопросы организации распределенных вычислений и общие принципы взаимодействия клиентов и серверов в распределенных системах. Данная статья посвящена одной из многочисленных реализаций технологии распределенных вычислений - технологии Microsoft COM (точнее, ее расширению - COM+).

В отличие от технологий CORBA (Component Object Request Broker Architecture) или DCE (Distributed Computing Environment), появившихся изначально в виде спецификаций и лишь затем - в виде конкретных реализаций в виде продуктов тех или иных производителей, Microsoft COM появилась одновременно и в виде спецификации (т.е. правил создания серверов и клиентов, описания соответствующего API, диалекта IDL и др.), и в виде реализации (функции Windows API, утилиты в составе различных SDK, поддержка и широкое использование данной технологии в операционных системах Windows 95/98/NT, вплоть до использования реестра в качестве регистрационной базы данных COM-сервисов и списков пользователей сети при определении прав доступа к сервисам, а также поддержка COM в других программных продуктах Microsoft). Это обусловило широкую популярность COM как технологии, реализующей объектно-ориентированный подход не на уровне реализации кода, а на уровне сервисов и приложений операционной системы, несмотря на ограниченный спектр поддерживаемых этой технологией платформ (пока это различные версии Windows, хотя информация о предстоящих реализациях для других операционных систем уже начинает появляться), а также несмотря на то, что, в сущности, в COM как технологии организации распеределенных вычислений нет, по существу, ничего революционного. И вызовы удаленных процедур, и создание stub- и proxy-объектов, и регистрация сервисов в специализированных базах данных, и язык IDL как средство описания интерфейсов сервера и сервисов - все это было придумано задолго до возникновения COM (и даже задолго до появления Windows).

Отметим, однако, что COM, если следовать ее спецификациям, позволяет решить множество проблем программирования для Windows, таких как существование различных версий одних и тех же библиотек (и возможность замены новых версий библиотек старыми при установке тех или иных программных продуктов), наличие нескольких реализаций одной и той же спецификации сервиса, присутствие нескольких сервисов в одной библиотеке и др., что также существенно повлияло на популярность COM. Однако подробное обсуждение этих возможностей выходит за рамки данной статьи. Интересующиеся этими аспектами могут более подробно ознакомиться с ними на сайте Microsoft (см., например, Brockschmidt K. What OLE is really about, www.microsoft.com/oledev/olecom/aboutole.html).

Более существенным фактором при рассмотрении имеющихся возможностей организации распределенных вычислений является то, что использование для этой цели COM является одним из самых недорогих решений. Регистрационная база данных (реестр) - это составная часть операционной системы, и, соответственно, не нуждается в отдельном приобретении; поддержка DCOM (Distributed COM) в виде соответствующих сервисов либо также присутствует в операционной системе (Windows NT), либо доступна бесплатно (Windows 95). Сервисы, занимающиеся поиском одной из нескольких реализаций сервера для данного клиента (directory services), в DCOM как таковом отсутствуют - местоположение реализации сервера фиксируется при настройке DCOM для конкретного клиента (есть, конечно, надстройки над COM, обеспечивающие такой сервис, например, Inprise OLEnterprise, но их использование не является обязательным).

Из этого, конечно, не следует, что распределенная информационная система с помощью COM/DCOM может быть создана бесплатно. Если удаленный сервер предоставляет клиентам сервисы доступа к данным, приобретению подлежат лицензии на клиентскую часть серверной СУБД (при этом их число может быть равным не числу серверов, а числу конечных пользователей - все определяется лицензионным соглашением производителя серверной СУБД). Помимо этого, могут быть и другие лицензии, подлежащие приобретению в этом случае, например, лицензия на многопользовательский доступ к Borland Database Engine, входящая в состав продукта Inprise MIDAS. Однако даже с учетом этих затрат общая стоимость такой информационной системы оказывается существенно ниже, чем при использовании, например, Inprise Entera. Естественно, чрезвычайно высоких требований к надежности систем на основе COM при этом предъявлять не стоит, но во многих случаях такое решение может оказаться вполне удовлетворительным.

Весьма популярным сейчас направлением развития информационных систем малых и средних предприятий является создание трехзвенных систем с использованием технологии Inprise MIDAS, базировавшейся до недавнего времени на том, что серверы доступа к данным представляют собой не что иное, как COM-серверы, а именно серверы автоматизации, поддерживающие интерфейс IDataBroker (сейчас серверы MIDAS могут быть не только COM-, но и CORBA-серверами, но об этом будет рассказано в других статьях данного цикла). О популярности этого направления свидетельствует превышающее все разумные пределы количество писем, поступившее в ответ на чуть ли не единственную опубликованную более года назад статью на эту тему в данном издании, а также устойчивый спрос на консалтинговые услуги и коммерческие курсы, посвященные данной теме.

В данной работе не содержится детальных подробностей создания обычных MIDAS-серверов и клиентов; предполагается, что читатели с ними уже знакомы. Интересующиеся данным вопросом могут обратиться к статье "Создание серверов приложений с помощью Delphi 3" ("Компьютер-Пресс", 1997, N 12, с.106-113; данная статья также доступна на сайтах www.interface.ru и www.citforum.ru). Отметим лишь, что при всей кажущейся простоте создания многозвенных систем с помощью этой технологии при ее практическом использовании в промышленных масштабах могут возникнуть некоторые проблемы.

1.2. Проблемы эксплуатации COM-серверов и COM+

Разработчики COM-серверов нередко сталкиваются с различными проблемами при их создании и эксплуатации. В частности, при разработке COM-серверов для доступа к данным, обслуживающих нескольких клиентов, следует позаботиться о поддержке нескольких соединений с базой данных и о работе с несколькими потоками. Создание подобного кода с помощью удаленных модулей данных Delphi или C++Builder, содержащих компоненты TDatabase и TSession, не представляет особых сложностей. Однако при большом числе обслуживаемых клиентов наличие подобного многопользовательского сервиса предъявляет серьезные требования к аппаратному обеспечению компьютера, на котором этот сервис функционирует. Поэтому нередко разработчики пытаются создать дополнительный код для осуществления совместного доступа многих клиентов к нескольким соединениям с базой данных, при этом число последних должно быть по возможности минимальным (обычно для такого разделения ресурсов используется термин "database connection pooling", и в комплекте поставки Delphi 4 Client/Server Suite имеется соответствующий пример).

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

Еще одна проблема, с которой сталкиваются разработчики приложений, предназначенных для работы с серверными СУБД - обработка транзакций, представляющих собой изменение данных в нескольких таблицах, которые либо все вместе выполняются, либо все вместе отменяются. Нередко код, описывающий транзакцию в стандартной двухзвенной клиент серверной системе, содержится в клиентском приложении, а не в серверной части, просто потому, что в случае отката транзакции клиентское приложение должно быть уведомлено об этом. Что касается распределенных транзакций, использующих синхронные изменения в нескольких разных базах данных, их обработка практически всегда производится только в клиентском приложении. Подобные требования усложняют написание клиентских приложений, особенно если в информационной системе их несколько, и повышают соответствующие требования к аппаратной части рабочих станций. Нередко с целью изъятия кода обработки транзакций из клиентского приложения разработчики создают специализированные сервисы, ответственные за обработку транзакций (так называемые мониторы транзакций; есть и специальные продукты, предназначенные для управления распределенными транзакциями).

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

Таким образом, имеется потребность в расширении COM-технологии за счет сервиса, обеспечивающего создание COM-объектов для совместного использования многими клиентами, авторизованный доступ к этим объектам, а также при необходимости обработку транзакций этими объектами. Расширенная таким образом технология COM получила название COM+, а сам сервис, реализующий это расширение, получил название Microsoft Transaction Server (MTS).

Итак, Microsoft Transaction Server представляет собой сервис, обеспечивающий централизацию использования серверов автоматизации, а также управление транзакциями и совместное использование несколькими клиентами соединений с базой данных независимо от реализации сервера. Версия 2.0 этого сервиса входит в состав NT Option Pack (его можно получить на web-сайте Microsoft) и доступна для Windows NT и Windows 95/98. Однако некоторые возможности MTS (например, управление удаленными объектами) реализованы только в версии NT Option Pack для Windows NT.

Отметим, что, помимо создания COM-объектов для коллективного пользования, предоставления сервисов авторизации пользователя при доступе к объектам и обработки транзакций, MTS предоставляет средства мониторинга объектов и транзакций, что упрощает их реализацию.

2. Как работает MTS?

Серверы MTS создаются точно так же, как и обычные внутренние серверы автоматизации. Иными словами, они представляют собой динамически загружаемые библиотеки, реализующие интерфейс IDispatch. Однако регистрация таких объектов происходит по-другому.

Обычные COM-серверы могут быть найдены их клиентами только в том случае, если они зарегистрированы в реестре Windows; в этом случае местоположение исполняемого файла или библиотеки, содержащей его реализацию, определяется путем поиска в реестре записи, содержащей идентификатор (GUID) данного сервера. Если же COM-сервер выполняется под управлением MTS, он регистрируется не непосредственно в реестре, а в окружении MTS. Клиент при этом взаимодействует с исполняемым файлом mtx.exe как с локальным или удаленным сервером автоматизации.

Серверные объекты могут быть объединены в так называемые "пакеты" (packages). "Пакеты" бывают двух типов: Library package (выполняются в адресном пространстве породившего такой "пакет" клиента; естественно, в этом случае удаленный запуск такого "пакета" невозможен) и Server package (выполняются внутри отдельного процесса; в этом случае возможен их удаленный запуск).

2.1. Управление транзакциями

Для управления распределенными транзакциями используется специальный сервис - Microsoft Distributed Transaction Coordinator (MS DTC), который может быть активизирован или с помощью Windows Control Panel, или непосредственно из MTS Explorer.

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

Отметим, что объекты MTS могут инициировать создание других объектов MTS (назовем их дочерними объектами). При этом, если в дочернем объекте генерируется исключение при выполнении каких-либо его методов, MTS информируется о необходимости отката транзакции. Объект-родитель при этом не обязан контролировать успешность выполнения операций дочерним объектом, так как в случае исключения в дочернем объекте MTS сам инициирует откат транзакции, порожденной родительским объектом, и уведомит об этом клиента. За счет такого механизма уведомлений и реализуется возможность управления распределенными транзакциями, то есть согласованными изменениями данных в таблицах, принадлежащих к разным базам данных - в этом случае код, отвечающий за работу с этими таблицами, следует поместить в разные объекты MTS, и инициировать их запуск из какого-либо другого объекта. Иными словами, на базе MTS возможно создание так называемых мониторов транзакций.

2.2. Вопросы безопасности

MTS позволяет использовать список пользователей и групп пользователей Windows NT в качестве списка пользователей своих объектов. При этом для каждого объекта можно установить правила его эксплуатации различными пользователями и группами пользователей. Помимо этого, MTS поддерживает также механизм ролей, примерно аналогичный ролям некоторых серверных СУБД (роль представляет собой совокупность пользовательских прав и привилегий на использование тех или иных объектов, и может быть присвоена пользователю или группе пользователей). Соответственно, при использовании MTS можно не включать код реализации правил безопасности в серверные объекты.

2.3. Коллективное использование объектов (object pooling).

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

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

Для реализации коллективного использования объектов используются специальные объекты, которые называются resource dispencers (слово dispenser означает раздаточное устройство или распределитель). Эти объекты фактически кэшируют ресурсы так, что компоненты, находящиеся в одном "пакете", могут использовать их совместно. Из объектов подобного рода следует особо отметить BDE resource dispenser и Shared property manager.

BDE resource dispenser - это объект, устанавливаемый вместе с Delphi 4 и регистрируемый программой установки Delphi в среде MTS. Он управляет коллективным использованием соединений с базами данных, использующих BDE.

Shared property manager - это объект, позволяющий использовать общие свойства для нескольких различных серверных объектов.

3. Требования к объектам MTS.

Серверные объекты MTS, как уже было сказано выше, представляют собой COM-серверы, выполняемые в адресном пространстве среды MTS, и, следовательно, выполненные в виде динамически загружаемых библиотек (DLL).

Все компоненты MTS поддерживают специфический для них интерфейс IObjectControl, содержащий методы для активации и деактивации объекта MTS и управления ресурсами (в том числе соединениями с базами данных, рис. 1).

Рис. 1. Интерфейсы объекта MTS.

Как было сказано ранее, компоненты MTS могут функционировать как COM-объекты вне адресного пространства клиента (out-of-process server). В этом случае клиентское приложение взаимодействует с созданным внутри его адресного пространства proxy-объектом, передающим запросы клиента с помощью вызовов удаленных процедур содержащемуся внутри адресного пространства сервера stub-объекту, взаимодействующему с компонентом MTS посредством его интерфейса. Информация о соединении содержится в proxy-объекте. Последний может активизировать и деактивировать MTS-объект, отдавая ресурсы другим клиентам, нуждающимся в данном сервисе, незаметно для клиента.

Компоненты MTS могут также функционировать как внутренние серверы автоматизации (in-process-сервер). В этом случае их удаленный запуск исключен.

Серверный объект MTS должен иметь стандартную фабрику классов и библиотеку типов (они автоматически создаются при использовании MTS Object wizard). Можно редактировать библиотеку типов, добавляя свойства и методы (в дальнейшем они будут использованы MTS Explorer для получения сведений о его объектах на этапе выполнения). Помимо этого, компонент должен экспортировать функцию DllRegisterServer и осуществлять саморегистрацию его CLSID (идентификаторов класса сервиса), ProgID (идентификаторов сервера), интерфейсов, библиотеки типов (MTS Object wizard автоматически генерирует соответствующий код).

Если предполагается коллективное использование серверного объекта, он не должен хранить внутри себя сведения о состоянии данных, связанных с конкретным клиентом (для этого используются термины "stateless code" и "stateless object"). Пример создания такого кода будет рассмотрен ниже.

4. Пример 1: создание простейшего серверного объекта

Предварительная подготовка

Прежде чем приступить к созданию серверных объектов, предназначенных для работы под управлением MTS, следует убедиться в том, что сам MTS и Delphi 4 установлены корректно. Во-первых, NT Option Pack, содержащий MTS, следует обязательно установить до установки Delphi. Тогда в процессе установки Delphi при обнаружении инсталляционной программой установленной копии MTS в него будет добавлен специальный "пакет" (package) BDE-MTS, содержащий объект BdeMTSDispenser (его можно обнаружить с помощью MTS Explorer, рис. 2).

Рис. 2. BdeMTSDispenser, зарегистрированный в Microsoft Transaction Server.

Следует также убедиться, что данный объект поддерживает транзакции. C этой целью нужно из контекстного меню объекта BDEDispenser выбрать опцию Properties и в появившейся диалоговой панели выбрать закладку Transaction (рис. 3):

Рис. 3. Установка поддержки транзакций объектом MTS.

Далее следует запустить BDE Administrator, открыть страницу Configuration, выбрать раздел System/Init и установить значение параметра MTS POOLING равным TRUE. Только при этом значении данного параметра возможна поддержка транзакций и коллективное использование соединений с базами данных, доступных с помощью BDE (рис. 4).

Рис. 4. Установка опции MTS POOLING для коллективного использования соединений с базами данных

Для выполнения описанных ниже примеров следует создать три таблицы в трех разных базах данных. Первая из них требует наличия сервера IB Database (он входит в комплект поставки Delphi 4) и должна быть создана в базе данных IBLOCAL с помощью следующего скрипта:

Code: CREATE TABLE STOCKTABLE ( GOODSNAME CHAR(30), PRICE FLOAT, GOODSNUMBER INTEGER NOT NULL).

Использование native kernel32 функций для получения проекции физической памяти

Использование native kernel32 функций для получения проекции физической памяти

© 2006 Альберт Мамедов (MagDelphi).

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

Платформа WinNT(XP) не допускает возможность непосредственного доступа к памяти средствами Win32API. В этом случае программист должен или написать свой драйвер доступа к физической памяти или использовать native kernel32 функции ядра.

Рассмотрим второй вариант использующий объект "проекция файла" (file-mapping object), представляющем собой блок памяти(раздел) доступный двум и более процессам для совместного использования.

Совместное использование данных с помощью объекта "раздел" происходит следующим образом: Задав атрибуты с помощью функции

Code: Procedure InitializeObjectAttributes(InitializedAttributes : PNtObjectAttributes; PObjectName : PNtUnicodeString; Const uAttributes : ULONG; Const hRootDirectory : THandle; PSecurityDescriptor : PSECURITY_DESCRIPTOR); Begin. With InitializedAttributes^ do. Begin. Length := SizeOf(TNtObjectAttributes); ObjectName := pObjectName; Attributes := uAttributes; RootDirectory := hRootDirectory; SecurityDescriptor := pSecurityDescriptor; SecurityQualityOfService := nil; End; End;

Использование сохраненных процедур.

Использование сохраненных процедур

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

В этой главе обсуждаются следующие темы:

· Дается общий обзор сохраненных процедур;

· Объясняется, как создавать и выполнять сохраненные процедуры;

· Объясняется, как возвращать информацию из сохраненных процедур;

· Приводятся правила, связанные с сохраненными процедурами;

· Объясняется, как удалять и переименовывать сохраненные процедуры;

· Описывается, как использовать системные сохраненные процедуры;

· Объясняется, как получать информацию о сохраненных процедурах.

Что такое сохраненные процедуры

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

· Содержать параметры (аргументы);

· Вызывать другие процедуры;

· Возвращать свой статус вызывающей процедуре или пакету, указывающий на успешное окончание или ошибку, и в случае ошибки на ее причину;

· Возвращать значения параметров вызывающей процедуре или пакету;

· Выполняться на удаленном SQL Сервере.

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

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

С SQL Сервером предоставляется большое число сохраненных процедур в качестве удобных инструментов для пользователя. Эти сохраненные процедуры называются системными сохраненными процедурами.

Сохраненные процедуры создаются с помощью команды create procedure (создать процедуру). Для выполнения сохраненной процедуры, как системной, так и определенной пользователем, используется команда execute (выполнить). Можно также просто указать название сохраненной процедуры, если оно является первым словом в операторе или пакете.

Примеры создания и использования сохраненных процедур

Синтаксис для создания простой сохраненной процедуры без параметров выглядит так:

Create procedure название_процедуры.

As SQL_операторы.

Сохраненные процедуры являются объектами базы данных и их название должны соответствовать правилам для идентификаторов.

В сохраненной процедуре допускается использование любого числа SQL операторов любого типа, за исключением операторов create (создать). См. раздел “Правила, связанные с сохраненными процедурами”. Сохраненная процедура может быть состоять из одного оператора, перечисляющего имена пользователей базы данных:

Create procedure namelist.

As select name from sysusers.

Для выполнения сохраненной процедуры нужно использовать ключевое слово execute, за которым следует название сохраненной процедуры, или просто указать название процедуры, если оно одно сообщается SQL Серверу, или является первым оператором в пакете. Процедура namelist может быть выполнена любым из следующих способов:

Namelist.

Execute namelist.

Exec namelist.

Для выполнения сохраненной процедуры на удаленном SQL Сервере необходимо указать название сервера. Полный синтаксис вызова удаленной процедуры выглядит так:

Execute название_сервера.[название_базы_данных].[владелец].название_процедуры.

В следующих примерах процедура namelist из базы данных pubs2 выполняется на удаленном сервере GATEWAY:

Execute gateway.pubs2..namelist.

Gateway.pubs2.dbo.namelist.

Exec gateway...namelist.

Последний вариант будет работает только, если pubs2 является базой данных, заданной по умолчанию.

Название базы данных является необязательным параметром только, если сохраненная процедура находится в базе данных заданной по умолчанию (default database). Имя владельца процедуры является необязательным только, если владельцем процедуры является владелец базы данных (“dbo”) или сам пользователь, вызывающий эту процедуру. Безусловно необходимо иметь разрешение (permission) для выполнения процедуры.

Процедура может содержать несколько операторов.

Create procedure showall as.

Select count(*) from sysusers.

Select count(*) from sysobjects.

Select count(*) from syscolumns.

Во время выполнения процедуры, результаты работы каждой команды выводятся в том порядке, в каком эти команды указаны в процедуре.

Showall.

------------

5.

(Выбрана 1 строка).

------------

88.

(Выбрана 1 строка).

------------

349.

(1 row affected, return status = 0).

Если команда create procedure выполнилась успешно, то название процедуры заносится в таблицу sysobjects, а ее текст в syscomments.

Текст процедуры может быть выведен с помощью системной процедуры sp_helptext:

Sp_helptext showall.

# Lines of Text.

---------------

1.

(1 row affected).

Text.

----------------------------- ----------

Create procedure showall as.

Select count(*) from sysusers.

Select count(*) from sysobjects.

Select count(*) from syscolumns.

(1 row affected, return status = 0).

Сохраненные процедуры и права доступа

Сохраненные процедуры могут служить в качестве механизма обеспечения секретности, поскольку пользователь может получить разрешение на выполнение сохраненной процедуры, даже в том случае если у него или у нее нет разрешения на обращение к таблицам или вьюверам, к которым обращается процедура, или нет разрешения на выполнение определенных команд. Более детально этот вопрос обсуждается Руководстве пользователя по средствам ограничения доступа SQL Сервера (Security Features User’s Guide).

Сохраненные процедуры и производительность

Во время изменения базы данных можно переоптимизировать исходный план запроса, который используется для доступа к таблицам, ре компилируя его с помощью системной процедуры sp_recompile. Это позволяет избежать нахождения, удаления и повторного создания каждой сохраненной процедуры или триггера. Следующий пример помечает каждую сохраненную процедуру и триггер, который осуществляет доступ к таблице titles, для того, чтобы рекомпилировать их во время каждого следующего выполнения.

Sp_recompile titles.

Более детально о команде sp_recompile можно узнать из Справочного руководства SQL Сервера.

Создание и выполнение сохраненных процедур

Полный синтаксис команды create procedure выглядит так:

Create procedure [владелец.]название_процедуры[;номер] [

[(] @название_параметра тип_данных [= default] [output].

[, @название_параметра тип_данных [= default] [output]]...[)]] [with.

Recompile].

As sql_операторы.

Создавать процедуру можно только в текущей базе данных.

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

Далее приводится полный синтаксис оператора execute:

[execute] [@return_status =].

[[[сервер.]база_данных.]владелец.]название_процедуры[;номер].

[[@название_параметра = ] значение |

[@название_параметра = ] @переменная [output].

[,[@название_параметра = ] значение |

[@название_параметра = ] @переменная [output]...]].

[with recompile].

Замечание: Вызов удаленной процедуры не является частью транзакции. Если вызов удаленной процедуры происходит после слов begin transaction (начать транзакцию), а затем встречается команда rollback transaction (откатить транзакцию), то любые изменения, которые произвела удаленная процедура над удаленными данными, не восстанавливаются. Создатель сохраненной процедуры должен быть уверен, что все условия, которые могут вызвать откат со стороны триггера, должны проверяться перед вызовом удаленной процедуры, которая может изменить удаленные данные.

Параметры

Параметр - это аргумент сохраненной процедуры. Один или несколько параметров могут быть объявлены в операторе создания процедуры. Значение каждого параметра, объявленного в операторе create procedure, должно указываться пользователем в момент вызова процедуры.

Названиям параметров должен предшествовать символ “@”, а сами эти названия должны соответствовать правилам, установленным для идентификаторов. Для всех параметров должен быть указан системный или пользовательский тип данных, и если необходимо длина этого типа данных. Названия параметров являются локальными по отношению к содержащей их процедуре; такие же названия можно использовать для параметров в другой процедуре. Названия параметров не должны превышать 30 байтов, включая символ “@”.

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

Create proc au_info @lastname varchar(40),

@firstname varchar(20) as.

Select au_lname, au_fname, title, pub_name.

From authors, titles, publishers, titleauthor.

Where au_fname = @firstname.

And au_lname = @lastname.

And authors.au_id = titleauthor.au_id.

And titles.title_id = titleauthor.title_id.

And titles.pub_id = publishers.pub_id.

Теперь выполним процедуру au_info:

Au_info Ringer, Anne.

Au_lname au_fname title pub_name.

-------- -------- --------------------- ----------

Ringer Anne The Gourmet Microwave Binnet & Hardley.

Ringer Anne Is Anger the Enemy? New Age Books.

(2 rows affected, return status = 0).

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

Create proc showind @table varchar(30) as.

Select table_name = sysobjects.name,

Index_name = sysindexes.name, index_id = indid.

From sysindexes, sysobjects.

Where sysobjects.name = @table.

And sysobjects.id = sysindexes.id.

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

Execute showind titles.

Exec showind titles.

Execute showind @table = titles.

Execute GATEWAY.pubs2.dbo.showind titles.

Showind titles.

Последняя синтаксическая форма, не содержащая ключевого слова exec или execute, допустима только, если этот оператор является единственным в строке или первым оператором в пакете.

Ниже приведены результаты выполнения процедуры showind в базе данных pubs2, когда параметром является название таблицы titles:

Table_name index_name index_id.

---------- ---------- ----------

Titles titleidind 1.

Titles titleind 2.

(2 rows affected, return status = 0).

Замечание: Если параметры задаются в виде “@параметр=значение”, то их можно задавать в любом порядке. В противном случае, они должны быть заданы в том же порядке, в каком они указаны в операторе create procedure. Если хотя бы один параметр был задан в виде “@параметр=значение ”, то все остальные параметры должны быть заданы в таком же виде.

Значения по умолчанию для параметров

В операторе create procedure для параметра можно указать значение, принимаемое по умолчанию. Это значение, которое может быть любой константой, используется в качестве аргумента процедуры, если для этого параметра не было указано никакого значения.

Далее приведена процедура, которая выводит имена всех авторов, которые написали книги, опубликованные заданным издательством. Если название издательства не указано, то процедура выводит имена авторов, которые изданы в Algodata Infosystems.

Create proc pub_info.

@pubname varchar(40) = "Algodata Infosystems" as.

Select au_lname, au_fname, pub_name.

From authors a, publishers p, titles t, titleauthor ta.

Where @pubname = p.pub_name.

And a.au_id = ta.au_id.

And t.title_id = ta.title_id.

And t.pub_id = p.pub_id.

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

При запуске процедуры pub_info необходимо задать название издательства в качестве значения параметра. Если это название не указано, то по умолчанию используется название Algodata Infosystems.

Exec pub_info.

Au_lname au_fname pub_name.

-------------- ------------ --------------------

Green Marjorie Algodata Infosystems.

Bennet Abraham Algodata Infosystems.

O'Leary Michael Algodata Infosystems.

MacFeather Stearns Algodata Infosystems.

Straight Dick Algodata Infosystems.

Carson Cheryl Algodata Infosystems.

Dull Ann Algodata Infosystems.

Hunter Sheryl Algodata Infosystems.

Locksley Chastity Algodata Infosystems.

(9 rows affected, return status = 0).

В следующей процедуре showind2 параметру @table присваивается по умолчанию значение “titles”:

Create proc showind2 @table varchar(30) = titles.

As.

Select table_name = sysobjects.name,

Index_name = sysindexes.name, index_id = indid.

From sysindexes, sysobjects.

Where sysobjects.name = @table.

And sysobjects.id = sysindexes.id.

Заголовки столбцов, например table_name, добавлены для более наглядного вывода результатов. Ниже показано, что выдает эта процедура для таблицы authors, заданной в качестве аргумента:

Showind2 authors.

Table_name index_name index_id.

----------- ------------- ----------

Authors auidind 1.

Authors aunmind 2.

(2 rows affected, return status = 0).

Если пользователь не указывает никакого параметра для этой процедуры, то SQL Сервер по умолчанию будет использовать таблицу titles:

Showind2.

Table_name index_name index_id.

----------- ----------- ---------

Titles titleidind 1.

Titles titleind 2.

(2 rows affected, return status =0).

Если в процедуре предусмотрен параметр, но он не указан, и в операторе create procedure для этого параметра не указано никакого значения по умолчанию, то SQL Сервер выводит сообщение об ошибке и перечисляет параметры, которые должны быть заданы.

NULL как значения по умолчанию для параметра

Значение по умолчанию может быть неопределенным (NULL). В этом случае, если пользователь не указывает параметр, то SQL Сервер не выдает сообщения об ошибке и выполняет сохраненную процедуру.

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

Create procedure showind3 @table varchar(30) = null.

As.

If @table is null.

Print "Please give a table name".

Else.

Select table_name = sysobjects.name,

Index_name = sysindexes.name, index_id = indid.

From sysindexes, sysobjects.

Where sysobjects.name = @table.

And sysobjects.id = sysindexes.id.

Если пользователь забыл ввести значения параметра, то SQL Сервер выведет на экран указанное в процедуре сообщение.

Другие примеры установки неопределенного значения в качестве значения по умолчанию можно увидеть в тексте системных процедур с помощью процедуры sp_helptext.

Символы замены в значениях по умолчанию параметров

Если в процедуре используется параметр с ключевым словом like, то значение по умолчанию может содержать символы замены (%, _, [] и [^]).

В следующем примере процедура showind изменена таким образом, чтобы она выдавала информацию о системных таблицах, если пользователь не указал название таблицы в качестве параметра:

Create procedure showind4 @table varchar(30)="sys%".

As.

Select table_name = sysobjects.name,

Index_name = sysindexes.name, index_id = indid.

From sysindexes, sysobjects.

Where sysobjects.name like @table.

And sysobjects.id = sysindexes.id.

Использование нескольких параметров

Ниже приведен один из вариантов сохраненной процедуры au_info, которая содержит значения по умолчанию с символами замены для обоих параметров:

Create proc au_info2 @lastname varchar(30) = "D%",

@firstname varchar(18) = "%" as.

Select au_lname, au_fname, title, pub_name.

From authors, titles, publishers, titleauthor.

Where au_fname like @firstname.

And au_lname like @lastname.

And authors.au_id = titleauthor.au_id.

And titles.title_id = titleauthor.title_id.

And titles.pub_id = publishers.pub_id.

Если процедура au_info2 выполняется без параметров, то выдаются фамилии всех писателей, которые начинаются с буквы D:

Au_info2.

Au_lname au_fname title pub_name.

-------- ------- ------------------------- -------------

Dull Ann Secrets of Silicon Valley Algodata Infosystems.

DeFrance Michel The Gourmet Microwave Binnet & Hardley.

(2 rows affected).

Если для параметров указаны значения по умолчанию, то при вызове процедуры параметры могут быть опущены, начиная с последнего параметра, после которого все параметры имеют умолчания. Параметр нельзя пропустить, если его значение по умолчанию не равно NULL.

Замечание: Если параметры задаются в виде “@параметр=значение”, то они могут располагаться в любом порядке. Можно также пропустить любой параметр, если для него указано значение по умолчанию.

Если хотя бы один параметр был задан в виде “@параметр=значение”, то остальные параметры должны быть заданы в таком же виде.

Чтобы проиллюстрировать вызов процедуры с явно заданным одним параметром, когда для двух параметров указаны значения по умолчанию, рассмотрим следующий пример, в котором запрашиваются названия всех книг, написанных автором по фамилии «Ringer», вместе с издательствами их опубликовавшими:

Au_info2 Ringer.

Au_lname au_fname title Pub_name.

-------- -------- --------------------- ------------

Ringer Anne The Gourmet Microwave Binnet & Hardley.

Ringer Anne Is Anger the Enemy? New Age Books.

Ringer Albert Is Anger the Enemy? New Age Books.

Ringer Albert Life Without Fear New Age Books.

(4 rows affected).

Группы процедур

Необязательная точки с запятой вместе с целым числом после названия процедуры в операторах create procedure и execute позволяют группировать процедуры с одинаковым названиями так, что они могут быть удалены одновременно одним оператором drop procedure (удалить процедуру).

Процедуры, которые используются в одном и том же приложении, часто группируются таким образом. Например, можно создать последовательность процедур orders;1, orders;2, и т.д. Следующий оператор будет удалять всю эту группу:

Drop proc orders.

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

Drop proc orders;2.

Конструкция recompile в операторе create procedure

В операторе создания процедуры create procedure необязательная конструкция with recompile (с перекомпилированием) расположена точно перед SQL-операторами, составляющими тело процедуры. Она сообщает SQL Серверу о том, что не нужно сохранять план выполнения процедуры, поскольку при каждом запуске этой процедуры будет создаваться новый план ее выполнения.

Если конструкция with recompile не указана, то SQL Сервер сохраняет созданный план выполнения процедуры. Обычно этот план является вполне удовлетворительным.

Однако, возможны ситуации, когда изменения данных или значений параметров, вынуждают SQL Сервер перейти к другому плану выполнения процедуры, отличному от того, который был создан во время первого выполнения процедуры. В таких ситуациях SQL Серверу требуется новый план выполнения процедуры.

Конструкцию with recompile в операторе создания процедуры следует использовать, когда пользователю может потребоваться новый план выполнения процедуры. Дополнительная информация об этом дается также в Справочном руководстве SQL Сервера.

Конструкция recompile в операторе execute

В операторе execute необязательная конструкция with recompile располагается сразу после параметров. Она сообщает SQL Серверу, что нужно создавать новый план выполнения процедуры. Новый план используется при дальнейших запусках процедуры.

Конструкцию with recompile следует указывать, если данные сильно изменились или среди значений параметров процедуры появились нетипичные, т.е. когда у пользователя есть уверенность, что текущий план выполнения процедуры не оптимален.

Замечание: Если в определении процедуры используется команда select *, то процедура не распознает новые столбцы, добавленные в таблицу, даже если в операторе execute используется опция with recompile. Такая процедура должна быть удалена и создана заново.

Вложенные процедуры

Вложение процедур возникает, когда одна сохраненная процедура или триггер вызывает другую процедуру. Уровень вложенности увеличивается, когда вызываемая процедура или триггер начинает свое выполнение, и уменьшается, когда вызываемая процедура или триггер заканчивают выполнение. Превышение максимального 16-го уровня вложенности ведет к прерыванию процедуры. Текущий уровень вложенности процедуры хранится в глобальной переменной @@nestlevel.

Временные таблицы в сохраненных процедурах

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

· Создавать временные таблицы;

· Вставлять, обновлять и удалять данные;

· Выполнять запросы над временными таблицами;

· Вызывать другие процедуры, которые обращаются к временной таблице.

Поскольку временная таблица должна уже существовать, когда создается процедура, которая к ней обращается, то далее даются варианты использования временных таблиц в процедурах:

1. Создайте необходимую временную таблицу с помощью операторов create table или select into. Например:

Create table #tempstores.

(stor_id char(4), amount money).

1. Создайте процедуру, которая имеет доступ к временной таблице (но не ту, что создает таблицу).

Create procedure inv_amounts.

As.

Select stor_id, "Total Due" =sum(amount).

From #tempstores.

Group by stor_id.

1. Удалите временную таблицу:

Drop table # tempstores.

1. Создайте процедуру, которая создает временную таблицу и вызывает процедуру, указанную в п. 2:

Create procedure inv_proc.

As.

Create table #tempstores.

(stor_id char(4), amount money).

Insert #tempstores.

Select stor_id, sum(qty*(100-discount)/100* rice).

From salesdetail, titles.

Where salesdetail.title_id = titles.title_id.

Group by stor_id, salesdetail.title_id.

Exec inv_amounts.

Можно создавать временные таблицы без префикса #, используя оператор create table tempdb..tablename.. в самой сохраненной процедуре. Эти таблицы не удаляются после завершения выполнения процедуры, поэтому на них могут ссылаться независимые процедуры. Для создания таких таблиц можно использовать способы, описанные в пп.1-4.

Выполнение удаленных процедур

Процедуры можно выполнять на SQL Сервере, отличном от локального SQL Сервера. Если оба сервера имеют совместимые конфигурации, то можно выполнять любую процедуру на удаленном сервере, просто записывая название сервера как часть идентификатора. Например, для выполнения процедуры remoteproc на удаленном сервере GATEWAY, нужно выполнить следующую команду:

Exec gateway.remotedb.dbo.remoteproc.

Информацию о том, как конфигурировать локальный и удаленный серверы для выполнения удаленных процедур, можно посмотреть в Руководстве системного администратора. Из пакета или процедуры, содержащей оператор execute, вызывающий удаленную процедуру, можно передать в нее один или несколько значений в качестве параметров. Результаты выполнения процедуры на удаленном сервере появляются на локальном терминале пользователя.

Статус (состояние), возвращаемое процедурой и описываемое в следующих разделах, может использоваться для получения и передачи информации о состоянии выполнения процедуры.

Внимание: Вызовы удаленных процедур не являются частью транзакции. Поэтому, если вызов удаленной процедуры является частью транзакции, а затем транзакция откатывается назад, то любые изменения, которые удаленная процедура произвела на удаленном сервере, не восстанавливаются.

Возврат информации из сохраненных процедур

Сохраненные процедуры сообщают свой «статус возврата», который указывает, была ли выполнена процедура полностью, или нет, а также причины неудачи. Это значение может храниться в переменной, которая передается процедуре при ее вызове, и использоваться в последующих операторах Transact-SQL. SQL Сервер резервирует значения в диапазоне от -1 до -99 для кодов возврата ошибочных ситуаций, которые могут возникнуть при выполнении процедуры; а значения, находящиеся вне этого диапазона, пользователи могут использовать для определения своих статусов (кодов) возврата.

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

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

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

Коды возврата

Сохраненные процедуры могут возвращать целое число, которое называется кодом возврата (return status). Это число показывает, была ли процедура выполнена полностью или указывает на причины неудачного выполнения. SQL Сервер имеет набор заранее определенных кодов возврата. Пользователю может определить свои собственные коды возврата. Ниже приведен пример пакета, в котором оператор execute возвращает код состояния:

Declare @status int.

Execute @status = pub_info.

Select @status.

Статус выполнения (код возврата) процедуры pub_info сохраняется в переменной @status. В этом примере код возврата просто выводится с помощью оператора select; в последующих примерах код возврата будет анализироваться с помощью условных конструкций.

Зарезервированные значения кодов возврата

SQL Сервер резервирует код 0 для указания успешного выполнения процедуры и значения в диапазоне от -1 до -99 для указания различных причин неудачи. В следующей таблице показаны коды возврата от 0 до -14 и даны их описания:

Таблица 14-1: Зарезервированные значения обратного статуса.

Код. Значение. 0. Процедура выполнена без ошибок. -1. Отсутствует объект. -2. Ошибка в типе данных. -3. Прекращение выполнения процедуры для выхода из тупика. -4. Нарушение прав доступа. -5. Синтаксическая ошибка. -6. Ошибка пользователя. -7. Недостаток ресурсов, например, памяти. -8. Не фатальная внутренняя проблема. -9. Достижение системного предела. -10. Фатальная внутренняя проблема. -11. Фатальная внутренняя проблема. -12. Испорчена таблица или индекс. -13. Испорчена база данных. -14. Аппаратная ошибка.

Кода от -15 до -99 зарезервированы для дальнейшего использования SQL Сервером.

Если во время выполнения процедуры возникает несколько ошибок, то возвращается наибольший по абсолютной величине код.

Коды возврата пользователя

Пользователь может определить свои собственные коды возврата из сохраненных процедур, добавляя параметр в операторе return (возврат). Коды от 0 до -99 зарезервированы SQL Сервером; остальные значения можно использовать для определения своих кодов. В следующем примере возвращается 1, если книга имеет правильный код контракта, и 2 во всех остальных случаях:

Create proc checkcontract @titleid tid.

As.

If (select contract from titles where.

Title_id = @titleid) = 1.

Return 1.

Else.

Return 2.

Следующая сохраненная процедура вызывает процедуру checkcontract, а затем код, возвращаемый этой процедурой, анализируется с помощью условного оператора:

Create proc get_au_stat @titleid tid.

As.

Declare @retvalue int.

Execute @retvalue = checkcontract @titleid.

If (@retvalue = 1).

Print "Contract is valid".

Else.

Print "There is not a valid contract".

Ниже показан результат выполнения процедуры get_au_stat, аргументом которой является идентификатор книги с правильным номером контракта:

Get_au_stat «MC2222».

Contract is valid.

Проверка прав доступа в процедурах

Если сохраненная процедура выполняет задачу системного администрирования, то пользователь должен иметь права на ее использование. (Информацию о правах см. в Руководстве пользователя по средствам ограничения доступа SQL Сервера). Функция proc_role позволяет проверить права (роль) пользователя во время выполнения процедуры. Она возвращает 1, если пользователь имеет соответствующие права. Различают три степени прав доступа: sa_role, sso_role, и oper_role.

Ниже приведен пример использования функции proc_role в процедуре test_proc, требующей от вызывающего ее пользователя прав доступа системного администратора:

Create proc test_proc.

As.

If (proc_role("sa_role") = 0).

Begin.

Print "You don't have the right role".

Return -1.

End.

Else.

Print "You have SA role".

Return 0.

Возвращаемые параметры

Если в операторах create procedure и execute указывается опция output (выход) в названии параметра, то процедура возвращает значение этого параметра вызывающему объекту. Этим объектом может быть SQL пакет или другая сохраненная процедура, которые используют возвращаемые значения в своей дальнейшей работе. Если возвращаемые параметры используются в операторе execute, который является частью пакета, то значения возвращаемых параметров вместе с заголовком выводятся на экран перед выполнением последующих операторов пакета.

Нижеприведенная процедура выполняет умножение двух целых чисел, которые передаются ей в качестве двух первых аргументов, а третий аргумент @result определяется с опцией output:

Create procedure mathtutor @mult1 int, @mult2 int,

@result int output.

As.

Select @result = @mult1 * @mult2.

Чтобы использовать процедуру mathtutor для целей обучения, можно объявить переменную @result и включить ее в оператор execute. Добавление ключевого слова output в операторе execute позволяет увидеть значения возвращаемого параметра.

Declare @result int.

Exec mathtutor 5, 6, @result output.

(return status = 0).

Return parameters:

-----------

30.

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

Mathtutor 5,6,32.

(return status=0).

Значение параметра, определенного с опцией output, должно передаваться через переменную, а не через константу. В следующем примере переменная @guess используется для передачи в процедуру mathtutor значения третьего параметра. При этом SQL Сервер выводит значение возвращаемого параметра:

Declare @guess int.

Select @guess = 32.

Exec mathtutor 5, 6, @result = @guess output.

(1 row affected).

(return status = 0).

Return parameters:

@result.

-----------

30.

Значения возвращаемых параметров выводятся всегда, независимо от того, изменились эти значения, или нет. Заметим, что:

· В предыдущем примере выходной параметр @result должен передаваться в виде “@параметр=@переменная”. Если бы он не был последним передаваемым параметром, то все следующие за ним параметры также должны передаваться в таком же виде;

· Переменную @result не нужно объявлять в вызывающем пакете, поскольку это название параметра процедуры mathtutor.

· Несмотря на то, что измененное значение параметра @result возвращается через переменную, указанную в операторе execute, в данном случае через переменную @guess, оно выводится под своим названием, т.е. @result.

Если в дальнейшем после оператора execute может потребоваться первоначальное значение переменной @guess, то его нужно сохранить в другой переменной перед вызовом процедуры. Следующий пример иллюстрирует использование переменной @store для хранения значения переменной во время выполнения сохраненной процедуры, и использование “нового” возвращаемого значения переменной @guess в условных конструкциях:

Declare @guess int.

Declare @store int.

Select @guess = 32.

Select @store = @guess.

Execute mathtutor 5, 6, @result = @guess output.

Select Your_answer = @store, Right_answer = @guess.

If @guess = @store.

Print "Right-o".

Else.

Print "Wrong, wrong, wrong!".

(1 row affected).

(1 row affected).

(return status = 0).

Return parameters:

@result.

-----------

30.

Your_answer Right_answer.

----------- ------------

32 30.

(1 row affected).

Wrong, wrong, wrong!

Ниже приведена сохраненная процедура, которая проверяет, влияет ли объем продажи новой книги на изменение гонорара ее автора. Параметр @pc определяется как выходной (output) параметр:

Create proc roy_check @title tid, @newsales int,

@pc int output.

As.

Declare @newtotal int.

Select @newtotal = (select titles.total_sales + @newsales.

From titles where title_id = @title).

Select @pc = royalty from roysched.

Where @newtotal >= roysched.lorange and.

@newtotal < roysched.hirange.

And roysched.title_id = @title.

Следующий SQL пакет вызывает процедуру roy_check после присваивания значения переменной percent. Значения возвращаемых параметров выводятся на экран перед выполнением следующего оператора пакета:

Declare @percent int.

Select @percent = 10.

Execute roy_check "BU1032", 1050, @pc = @percent output.

Select Percent = @percent.

Go.

(1 row affected).

(return status = 0).

Return parameters:

@pc.

-----------

12.

Percent.

-----------

12.

(1 row affected).

Следующая сохраненная процедура вызывает процедуру roy_check и использует возвращаемое в переменной percent значение в условном операторе:

Create proc newsales @title tid, @newsales int.

As.

Declare @percent int.

Declare @stor_pc int.

Select @percent = (select royalty from roysched, titles.

Where roysched.title_id = @title.

And total_sales >= roysched.lorange.

And total_sales < roysched.hirange.

And roysched.title_id=titles.title_id).

Select @stor_pc = @percent.

Execute roy_check @title, @newsales, @pc = @percent.

Output.

If.

@stor_pc != @percent.

Begin.

Print "Royalty is changed".

Select Percent = @percent.

End.

Else.

Print "Royalty is the same".

Если выполнить эту сохраненную процедуру с теми же параметрами, которые использовались в предыдущем пакете, то результаты будут следующими:

Execute newsales "BU1032", 1050.

Royalty is changed.

Percent.

-----------

12.

(1 row affected, return status = 0).

В двух предыдущих примерах, где вызывается процедура roy_check, @pc является названием параметра, который передается процедуре roy_check, а @percent является выходной переменной. Когда процедура newsales вызывает процедуру roy_check, то значение переменной @percent может изменяться в зависимости от значения других передаваемых параметров. Если нужно сравнить возвращаемое значение percent с первоначальным значением параметра @pc, то следует сохранить начальное значение в другой переменной. В предыдущем примере это значение сохраняется в переменной stor_proc.

Передача значений параметров

Значения параметров должны передаваться в следующем виде:

@параметр=@переменная.

Нельзя использовать константы в качестве параметров. В этом случае значение константы нужно предварительно запомнить в некоторой переменной. Параметры могут иметь любой тип данных языка SQL, за исключением text и image.

Замечание: Если сохраненная процедура требует нескольких параметров, то либо выходной параметр должен быть указан последним в операторе execute, либо все следующие после него параметры должны быть указаны в виде “@параметр=значение”.

Ключевое слово output

Ключевое слово output (выходной) можно сокращать до out , также как и execute можно сокращать до exec.

Сохраненные процедуры могут возвращать несколько значений, каждое из которых должно определяться как выходная (output) переменная в сохраненной процедуре и вызывающем операторе, например:

Exec myproc @a = @myvara out, @b = @myvarb out.

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

Правила, связанные с сохраненными процедурами

Приведем некоторые дополнительные правила для создания сохраненных процедур:

· В пакет можно поместить только один оператор create procedure (создать процедуру) вместе с телом этой процедуры и в этом случае в пакете не должно быть других SQL операторов;

· Тело процедуры может содержать любое количество SQL операторов любого типа, за исключением оператора use и следующих операторов создания объектов:

Create view.

Create default.

Create rule.

Create trigger.

Create procedure.

· Другие объекты базы данных можно создавать внутри процедуры. К объекту базы данных можно обратиться внутри этой же процедуры, если он был создан до того как к нему обратились. Поэтому оператор создания объекта базы данных нужно располагать в начале процедуры;

· Внутри сохраненной процедуры нельзя создать объект, затем удалить его, а затем снова создать новый объект с таким же названием;

· SQL Сервер создает объекты, определенные в процедуре, во время выполнения процедуры, а не во время ее компилирования;

· При выполнении процедуры, которая вызывает другую процедуру, вызываемая процедура может обращаться к объектам, созданным первой процедурой;

· Внутри процедуры разрешается обращаться к временным таблицам;

· Если внутри процедуры была создана временная таблица, то она существует только во время выполнения этой процедуры, и исчезает после выхода из процедуры;

· Максимальное число параметров сохраненной процедуры равно 255.

· Максимальное число локальных и глобальных переменных процедуры ограничивается только объемом доступной памяти.

Расширение названий объектов внутри процедур

Если многие пользователи обращаются к сохраненной процедуре, то названия объектов, которые используются в некоторых командах внутри процедуры, должны быть расширены именем владельца объекта. Такими командами являются: alter table, create table, drop table, truncate table, create index, drop index, update statistics, dbcc. Названия объектов, которые используются в других операторах, например select или insert, не требуют расширения, поскольку их названия уточняются во время компиляции процедуры.

Например, пользователь “Мэри” (mary), которая является владельцем таблицы marytab, должна расширить название своей таблицы, когда она используется с одной из перечисленных выше команд в том случае, если “Мэри” хочет дать возможность другим пользователям исполнять эту процедуру с указанной таблицей:

Create procedure p1.

As.

Create index marytab_ind.

On mary.marytab(col1).

Дело в том, что названия объектов уточняются во время выполнения процедуры. Если название таблицы marytab не расширить, то при выполнении процедуры пользователем c именем “Джон” (john), SQL Сервер будет искать таблицу marytab, владельцем которой является Джон. В предыдущем примере было показано правильное использование этого правила. SQL Серверу было сообщено, что нужно искать таблицу marytab, владельцем которой является Мэри.

Удаление сохраненных процедур

Сохраненные процедуры удаляются с помощью команды drop procedure (удалить процедуру). Синтаксис этой команды выглядит следующим образом:

Drop procedure [владелец.]название_процедуры.

[, [владелец.]название_процедуры] ...

Если сохраненная процедура, которая удаляется, вызывает другую сохраненную процедуру, то SQL Сервер выдает сообщение об ошибке. Однако, если создать новую процедуру с таким же названием вместо удаленной процедуры, то вызывающие ее процедуры будут успешно выполняться.

Группа процедур, т.е. несколько процедур с одинаковыми названиями, но с разными числовыми суффиксами, удаляются одним оператором drop procedure. Процедуры, объединенные в группу, не могут быть удалены независимо друг от друга.

Изменение названий сохраненных процедур

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

Sp_rename название_объекта, новое_название.

Например, чтобы процедуру с названием showall переименовать на countall нужно выполнить следующую команду:

Sp_rename showall, countall.

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

Переименование объектов внутри процедур

Если в сохраненной процедуре было изменено название какого-либо объекта, то она должна быть удалена и создана заново. На первый взгляд может показаться, что сохраненная процедура, которая обращается к переименованной таблице или вьюверу, выполняется правильно. В действительности, эта процедура будет работать правильно только до тех пор, пока SQL Сервер не перекомпилирует ее. Перекомпиляция может произойти по многим причинам и без специального уведомления пользователя.

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

Процедуры как механизм безопасности

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

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

Информацию о предоставлении и отзыве прав на сохраненные процедуры и другие объекты базы данных, можно посмотреть в Руководстве пользователя по средствам ограничения доступа SQL Сервера.

Системные процедуры

Системные процедуры могут быть полезными в следующих отношениях:

· Для ускорения доступа к системным таблицам;

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

В большинстве случаев системные таблицы обновляются только через сохраненные процедуры. Системный администратор может разрешить непосредственное обновление системных таблиц путем изменения конфигурационной переменной и выдачи команды reconfigure with override (реконфигурация с перезаписью). См. по этому поводу Руководство системного администратора SQL Сервера (System Administration Guide).

Названия всех системных процедур начинаются с приставки «sp_». Они создаются согласно сценарию installmaster (мастер инсталляции) в базе данных sybsystemprocs во время инсталляции SQL Сервера.

Системную процедуру можно запускать из любой базы данных. Если системная процедура вызывается из базы данных, отличной от sybsystemprocs, то любые ссылки к системным таблицам отображаются в базу данных, из которой процедура была запущена. Например, если владелец базы данных pubs2 запускает процедуру sp_adduser (добавить пользователя), то новый пользователь будет добавлен в таблицу pubs2..sysuser.

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

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

Другие системные процедуры могут запускаться любым пользователем, которой имеет право на использование оператора execute, но это право должно быть предоставлено из базы данных sybsystemprocs. Отсюда вытекают два следствия:

· Пользователь имеет право запускать системные процедуры из любой базы данных или ни из одной из них;

· Владелец базы данных пользователя не может непосредственно управлять доступом к системным процедурам из своей базы данных.

Более подробную информацию на эту тему см. в Руководстве системного администратора SQL Сервера.

Администрирование доступа

К этой категории относятся процедуры, выполняющие следующие действия:

· Добавление, удаление и выдача регистраций (logins) SQL Сервера;

· Добавление, удаление и выдача имен пользователей, групп и псевдонимов (alieses) базы данных;

· Изменение паролей и базы данных, принимаемой по умолчанию;

· Изменение владельца базы данных;

· Добавление, удаление и выдача удаленных серверов, которые имеют доступ к данному SQL Серверу;

· Добавление имен пользователей удаленных серверов, имеющих доступ к данному SQL Серверу.

К этой категории относятся следующие процедуры: sp_addlogin, sp_addalias, sp_addgroup, sp_adduser, sp_changedowner, sp_changegroup, sp_droplogin, sp_dropalias, sp_dropgroup, sp_dropuser, sp_helpgroup, sp_helpprotect, sp_helpuser, sp_password.

Удаленные серверы

К этой категории относятся процедуры, выполняющие следующие действия:

· Добавление, удаление и выдача удаленных серверов, которые имеют доступ к данному SQL Серверу;

· Добавление имен пользователей удаленных серверов, имеющих доступ к данному SQL Серверу.

К этой категории относятся следующие процедуры: sp_addremotelogin, sp_addserver, sp_dropremotelogin, sp_dropserver, sp_helpremotelogin, sp_helpserver, sp_remoteoption, sp_serveroption.

Определение данных и объекты базы данных

К этой категории относятся процедуры, выполняющие следующие действия:

· Связывание и развязывание правил и умолчаний;

· Добавление, удаление и выдача главных, внешних и общих ключей;

· Добавление, удаление и выдача типов данных пользователя;

· Переименование объектов базы данных и типов данных пользователя;

· Оптимизация сохраненных процедур и триггеров;

· Составление отчетов об объектах базы данных, пользовательских типах данных, зависимостях между объектами базы, базах данных, индексах, пространстве, занимаемом таблицами и индексами.

К этой категории относятся следующие процедуры: sp_bindefault, sp_bindrule, sp_unbindefault, sp_unbindrule, sp_foreignkey, sp_primarykey, sp_commonkey, sp_dropkey, sp_depends, sp_addtype, sp_droptype, sp_rename, sp_spaceused, sp_help, sp_helpdb, sp_helpindex, sp_helpjoins, sp_helpkey, sp_helptext, sp_indsuspect, sp_recompile.

Сообщения пользователя

К этой категории относятся процедуры, выполняющие следующие действия:

· Добавление сообщений пользователя в таблицу sysusermessages базы данных пользователя;

· Удаление сообщений пользователя из таблицы sysusermessages;

· Выбор сообщений из таблицы sysusermessages или таблицы sysmessages в базе данных master для вывода их с помощью операторов print и raiserror;

К этой категории относятся следующие процедуры: sp_addmessage, sp_dropmessage sp_getmessage.

Системное администрирование

К этой категории относятся процедуры, выполняющие следующие действия:

· Добавление, удаление и выдача устройств для хранения базы данных и логирующих (dump) устройств;

· Выдача запретов (locks), установленных опций базы данных и выполняющихся процессов пользователя;

· Изменение и вывод конфигурационных переменных;

· Наблюдение (monitoring) за активностью SQL Сервера.

К этой категории относятся следующие процедуры: sp_addumpdevice, sp_dropdevice, sp_helpdevice, sp_helpsort, sp_logdevice, sp_dboption, sp_diskdefault, sp_configure, sp_monitor, sp_lock, sp_who.

Дополнительная информация о системных процедурах, которые выполняют административные функции, дается в Руководстве системного администратора SQL Сервера. Полную информацию о системных процедурах можно также получить в Справочном руководстве SQL Сервера.

Получение информации о процедурах

Несколько системных процедур выдают информацию из системных таблиц о сохраненных процедурах.

Процедура sp_help

С помощью системной процедуры sp_help можно получить отчет о сохраненной процедуре. Например, пользователь может получить информацию о сохраненной процедуре byroyalty из базы данных pubs2 с помощью следующей команды:

Sp_help byroyalty.

Name Owner type Created_on.

-------- ------ ---------------- -------------------

Byroyalty dbo stored procedure Feb 9 1987 3:56PM.

Data_located_on_segment When_created.

--------------------------- --------------------

Parameter_name Type Length Param_order.

-------------- ------ ------ -----------

@percentage int 4 1.

(return status = 0).

С помощью этой же процедуры можно получить информацию (помощь) и о системных процедурах, если запустить sp_help из базы данных sybsystemprocs.

Процедура sp_helptext

Чтобы увидеть текст (тело) сохраненной процедуры, нужно вызвать системную процедуру sp_helptext:

Sp_helptext byroyalty.

# Lines of Text.

---------------

1.

(1 row affected).

Text.

---------------------------------------------------

Create procedure byroyalty @percentage int.

As.

Select au_id from titleauthor.

Where titleauthor.royaltyper = @percentage.

(1 row affected, return status = 0).

Чтобы увидеть текст системной процедуры нужно вызвать процедуру sp_helptext из базы данных sybsystemprocs.

Процедура sp_depends

Системная процедура sp_depends перечисляет все сохраненные процедуры, которые обращаются к указанному объекту, или все объекты, к которым обращается указанная процедура. Например, по следующей команде выдается список всех объектов, к которым обращается сохраненная процедура пользователя byroyalty:

Sp_depends byroyalty.

Things the object references in the current database.

Object type updated selected.

---------------- ----------- --------- --------

Dbo.titleauthor user table no no.

(return status = 0).

В следующем операторе процедура sp_depends используется для получения списка объектов, которые обращаются к таблице titleauthor:

Sp_depends titleauthor.

Things inside the current database that reference the object.

Object type.

-------------- ------------------

Dbo.titleview view.

Dbo.reptq2 stored procedure.

Dbo.byroyalty stored procedure.

(return status = 0).

Необходимо удалить процедуру, а затем вновь создать ее, если какой-либо из объектов внутри процедуры был переименован.

Системные процедуры были кратко рассмотрены в разделе «Системные процедуры» этой главы. Более полная информация о них дается в Справочном руководстве SQL Сервера.

©Drkb::02994.